crmPack coverage - 77.20%

Files
Source

#' @include Data-methods.R
#' @include Design-class.R
#' @include McmcOptions-class.R
#' @include Rules-methods.R
#' @include Simulations-class.R
#' @include helpers.R
#' @include mcmc.R
NULL

# nolint start

## ============================================================

##' Simulate outcomes from a CRM design
##'
##' @param object the \code{\linkS4class{Design}} object we want to simulate
##' data from
##' @param nsim the number of simulations (default: 1)
##' @param seed see \code{\link{set_seed}}
##' @param truth a function which takes as input a dose (vector) and returns the
##' true probability (vector) for toxicity. Additional arguments can be supplied
##' in \code{args}.
##' @param args data frame with arguments for the \code{truth} function. The
##' column names correspond to the argument names, the rows to the values of the
##' arguments. The rows are appropriately recycled in the \code{nsim}
##' simulations. In order to produce outcomes from the posterior predictive
##' distribution, e.g, pass an \code{object} that contains the data observed so
##' far, \code{truth} contains the \code{prob} function from the model in
##' \code{object}, and \code{args} contains posterior samples from the model.
##' @param firstSeparate enroll the first patient separately from the rest of
##' the cohort? (not default) If yes, the cohort will be closed if a DLT occurs
##' in this patient.
##' @param mcmcOptions object of class \code{\linkS4class{McmcOptions}},
##' giving the MCMC options for each evaluation in the trial. By default,
##' the standard options are used
##' @param parallel should the simulation runs be parallelized across the
##' clusters of the computer? (not default)
##' @param nCores how many cores should be used for parallel computing?
##' Defaults to the number of cores on the machine, maximum 5.
##' @param \dots not used
##' @param derive a named list of functions which derives statistics, based on the
##' vector of posterior MTD samples. Each list element must therefore accept
##' one and only one argument, which is a numeric vector, and return a number.
##'
##' @return an object of class \code{\linkS4class{Simulations}}
##'
##' @example examples/design-method-simulate-Design.R
##' @export
##' @importFrom parallel detectCores
##' @keywords methods
setMethod("simulate",
  signature =
    signature(
      object = "Design",
      nsim = "ANY",
      seed = "ANY"
    ),
  def =
    function(object, nsim = 1L, seed = NULL,
             truth, args = NULL, firstSeparate = FALSE,
             mcmcOptions = McmcOptions(),
             parallel = FALSE, nCores =
               min(parallel::detectCores(), 5), derive = list(),
             ...) {
      ## checks and extracts
      assert_function(truth)
      assert_flag(firstSeparate)
      assert_count(nsim, positive = TRUE)
      assert_flag(parallel)
      assert_count(nCores, positive = TRUE)

      args <- as.data.frame(args)
      nArgs <- max(nrow(args), 1L)

      ## seed handling
      RNGstate <- set_seed(seed)

      ## from this,
      ## generate the individual seeds for the simulation runs
      simSeeds <- sample.int(n = 2147483647, size = as.integer(nsim))

      ## the function to produce the run a single simulation
      ## with index "iterSim"
      runSim <- function(iterSim) {
        ## set the seed for this run
        set.seed(simSeeds[iterSim])

        ## what is now the argument for the truth?
        ## (appropriately recycled)
        thisArgs <- args[(iterSim - 1) %% nArgs + 1, , drop = FALSE]

        ## start the simulated data with the provided one
        thisData <- object@data

        # In case there are placebo
        if (thisData@placebo) {
          ## what is the probability for tox. at placebo?
          thisProb.PL <- h_this_truth(
            object@data@doseGrid[1],
            thisArgs,
            truth
          )
        }

        ## shall we stop the trial?
        ## First, we want to continue with the starting dose.
        ## This variable is updated after each cohort in the loop.
        stopit <- FALSE

        ## what is the next dose to be used?
        ## initialize with starting dose
        thisDose <- object@startingDose

        ## inside this loop we simulate the whole trial, until stopping
        while (!stopit) {
          ## what is the probability for tox. at this dose?
          thisProb <- h_this_truth(
            thisDose,
            thisArgs,
            truth
          )

          ## what is the cohort size at this dose?
          thisSize <- size(object@cohort_size,
            dose = thisDose,
            data = thisData
          )

          ## In case there are placebo
          if (thisData@placebo) {
            thisSize.PL <- size(object@pl_cohort_size,
              dose = thisDose,
              data = thisData
            )
          }

          thisData <- h_determine_dlts(
            data = thisData,
            dose = thisDose,
            prob = thisProb,
            prob_placebo = thisProb.PL,
            cohort_size = thisSize,
            cohort_size_placebo = thisSize.PL,
            dose_grid = object@data@doseGrid[1],
            first_separate = firstSeparate
          )

          ## what is the dose limit?
          doselimit <- maxDose(object@increments,
            data = thisData
          )

          ## generate samples from the model
          thisSamples <- mcmc(
            data = thisData,
            model = object@model,
            options = mcmcOptions
          )

          ## => what is the next best dose?
          thisDose <- nextBest(object@nextBest,
            doselimit = doselimit,
            samples = thisSamples,
            model = object@model,
            data = thisData
          )$value


          ## evaluate stopping rules
          stopit <- stopTrial(object@stopping,
            dose = thisDose,
            samples = thisSamples,
            model = object@model,
            data = thisData
          )

          stopit_results <- h_unpack_stopit(stopit)
        }

        ## get the fit
        thisFit <- fit(
          object = thisSamples,
          model = object@model,
          data = thisData
        )

        # Get the MTD estimate from the samples.

        target_dose_samples <- dose(
          mean(object@nextBest@target),
          model = object@model,
          samples = thisSamples
        )

        # Create a function for additional statistical summary.

        additional_stats <- lapply(derive, function(f) f(target_dose_samples))

        ## return the results
        thisResult <-
          list(
            data = thisData,
            dose = thisDose,
            fit =
              subset(thisFit,
                select = c(middle, lower, upper)
              ),
            stop =
              attr(
                stopit,
                "message"
              ),
            report_results = stopit_results,
            additional_stats = additional_stats
          )
        return(thisResult)
      }

      resultList <- get_result_list(
        fun = runSim,
        nsim = nsim,
        vars =
          c(
            "simSeeds",
            "args",
            "nArgs",
            "firstSeparate",
            "truth",
            "object",
            "mcmcOptions"
          ),
        parallel = parallel,
        n_cores = nCores
      )

      # format simulation output
      simulations_output <- h_simulations_output_format(resultList)

      ## return the results in the Simulations class object
      ret <- Simulations(
        data = simulations_output$dataList,
        doses = simulations_output$recommendedDoses,
        fit = simulations_output$fitList,
        stop_report = simulations_output$stop_matrix,
        stop_reasons = simulations_output$stopReasons,
        additional_stats = simulations_output$additional_stats,
        seed = RNGstate
      )

      return(ret)
    }
)




##' Simulate outcomes from a rule-based design
##'
##' @param object the \code{\linkS4class{RuleDesign}} object we want to simulate
##' data from
##' @param nsim the number of simulations (default: 1)
##' @param seed see \code{\link{set_seed}}
##' @param truth a function which takes as input a dose (vector) and returns the
##' true probability (vector) for toxicity. Additional arguments can be supplied
##' in \code{args}.
##' @param args data frame with arguments for the \code{truth} function. The
##' column names correspond to the argument names, the rows to the values of the
##' arguments. The rows are appropriately recycled in the \code{nsim}
##' simulations.
##' @param parallel should the simulation runs be parallelized across the
##' clusters of the computer? (not default)
##' @param nCores how many cores should be used for parallel computing?
##' Defaults to the number of cores on the machine, maximum 5.
##' @param \dots not used
##'
##' @return an object of class \code{\linkS4class{GeneralSimulations}}
##'
##' @example examples/design-method-simulate-RuleDesign.R
##' @export
##' @keywords methods
setMethod("simulate",
  signature =
    signature(
      object = "RuleDesign",
      nsim = "ANY",
      seed = "ANY"
    ),
  def =
    function(object, nsim = 1L, seed = NULL,
             truth, args = NULL,
             parallel = FALSE,
             nCores =
               min(parallel::detectCores(), 5L),
             ...) {
      ## checks and extracts
      assert_function(truth)
      assert_count(nsim, positive = TRUE)
      assert_flag(parallel)
      assert_count(nCores, positive = TRUE)

      args <- as.data.frame(args)
      nArgs <- max(nrow(args), 1L)

      ## seed handling
      RNGstate <- set_seed(seed)

      ## from this,
      ## generate the individual seeds for the simulation runs
      simSeeds <- sample(x = seq_len(1e5), size = as.integer(nsim))

      ## the function to produce the run a single simulation
      ## with index "iterSim"
      runSim <- function(iterSim) {
        ## set the seed for this run
        set.seed(simSeeds[iterSim])

        ## what is now the argument for the truth?
        ## (appropriately recycled)
        thisArgs <- args[(iterSim - 1) %% nArgs + 1, , drop = FALSE]

        ## so this truth is...
        thisTruth <- function(dose) {
          do.call(
            truth,
            ## First argument: the dose
            c(
              dose,
              ## Following arguments
              thisArgs
            )
          )
        }

        ## start the simulated data with the provided one
        thisData <- object@data

        ## shall we stop the trial?
        ## First, we want to continue with the starting dose.
        ## This variable is updated after each cohort in the loop.
        stopit <- FALSE

        ## what is the next dose to be used?
        ## initialize with starting dose
        thisDose <- object@startingDose

        ## inside this loop we simulate the whole trial, until stopping
        while (!stopit) {
          ## what is the probability for tox. at this dose?
          thisProb <- thisTruth(thisDose)

          ## what is the cohort size at this dose?
          thisSize <- size(object@cohort_size,
            dose = thisDose,
            data = thisData
          )

          ## simulate DLTs
          thisDLTs <- rbinom(
            n = thisSize,
            size = 1L,
            prob = thisProb
          )

          ## update the data with this cohort
          thisData <- update(
            object = thisData,
            x = thisDose,
            y = thisDLTs
          )

          ## evaluate the rule
          thisOutcome <- nextBest(object@nextBest,
            data = thisData
          )

          thisDose <- thisOutcome$value
          stopit <- thisOutcome$stopHere
        }

        ## return the results
        thisResult <-
          list(
            data = thisData,
            dose = thisDose
          )

        return(thisResult)
      }

      resultList <- get_result_list(
        fun = runSim,
        nsim = nsim,
        vars =
          c(
            "simSeeds",
            "args",
            "nArgs",
            "truth",
            "object"
          ),
        parallel = parallel,
        n_cores = nCores
      )

      ## put everything in the GeneralSimulations format:

      ## setup the list for the simulated data objects
      dataList <- lapply(resultList, "[[", "data")

      ## the vector of the final dose recommendations
      recommendedDoses <- as.numeric(sapply(resultList, "[[", "dose"))

      ## return the results in the GeneralSimulations class object
      ret <- GeneralSimulations(
        data = dataList,
        doses = recommendedDoses,
        seed = RNGstate
      )

      return(ret)
    }
)


##' Simulate outcomes from a dual-endpoint design
##'
##' @param object the \code{\linkS4class{DualDesign}} object we want to simulate
##' data from
##' @param nsim the number of simulations (default: 1)
##' @param seed see \code{\link{set_seed}}
##' @param trueTox a function which takes as input a dose (vector) and returns the
##' true probability (vector) for toxicity. Additional arguments can be supplied
##' in \code{args}.
##' @param trueBiomarker a function which takes as input a dose (vector) and
##' returns the true biomarker level (vector). Additional arguments can be
##' supplied in \code{args}.
##' @param args data frame with arguments for the \code{trueTox} and
##' \code{trueBiomarker} function. The column names correspond to the argument
##' names, the rows to the values of the arguments. The rows are appropriately
##' recycled in the \code{nsim} simulations.
##' @param sigma2W variance for the biomarker measurements
##' @param rho correlation between toxicity and biomarker measurements (default:
##' 0)
##' @param firstSeparate enroll the first patient separately from the rest of
##' the cohort? (not default) If yes, the cohort will be closed if a DLT occurs
##' in this patient.
##' @param mcmcOptions object of class \code{\linkS4class{McmcOptions}},
##' giving the MCMC options for each evaluation in the trial. By default,
##' the standard options are used
##' @param parallel should the simulation runs be parallelized across the
##' clusters of the computer? (not default)
##' @param nCores how many cores should be used for parallel computing?
##' Defaults to the number of cores on the machine, maximum 5.
##' @param \dots not used
##' @param derive a named list of functions which derives statistics, based on the
##' vector of posterior MTD samples. Each list element must therefore accept
##' one and only one argument, which is a numeric vector, and return a number.
##'
##' @return an object of class \code{\linkS4class{DualSimulations}}
##'
##' @example examples/design-method-simulate-DualDesign.R
##' @importFrom mvtnorm rmvnorm
##' @export
##' @keywords methods
setMethod("simulate",
  signature =
    signature(object = "DualDesign"),
  def =
    function(object, nsim = 1L, seed = NULL,
             trueTox, trueBiomarker, args = NULL,
             sigma2W, rho = 0,
             firstSeparate = FALSE,
             mcmcOptions = McmcOptions(),
             parallel = FALSE,
             nCores =
               min(parallel::detectCores(), 5), derive = list(),
             ...) {
      ## checks and extracts
      assert_function(trueTox)
      assert_function(trueBiomarker)
      assert_number(sigma2W, lower = 0)
      assert_number(rho, lower = -1, upper = 1)
      assert_flag(firstSeparate)
      assert_count(nsim, positive = TRUE)
      assert_flag(parallel)
      assert_count(nCores, positive = TRUE)

      args <- as.data.frame(args)
      nArgs <- max(nrow(args), 1L)

      ## get names of arguments (excluding the first one which is the dose)
      trueToxArgnames <- names(formals(trueTox))[-1]
      trueBiomarkerArgnames <- names(formals(trueBiomarker))[-1]

      ## this is the covariance matrix we assume:
      trueCov <- matrix(
        c(
          sigma2W, sqrt(sigma2W) * rho,
          sqrt(sigma2W) * rho, 1
        ),
        nrow = 2, byrow = TRUE
      )

      ## seed handling
      RNGstate <- set_seed(seed)

      ## from this,
      ## generate the individual seeds for the simulation runs
      simSeeds <- sample(x = seq_len(1e5), size = as.integer(nsim))

      ## the function to produce the run a single simulation
      ## with index "iterSim"
      runSim <- function(iterSim) {
        ## set the seed for this run
        set.seed(simSeeds[iterSim])

        ## what is now the argument for the true functions?
        ## (appropriately recycled)
        thisArgs <- args[(iterSim - 1) %% nArgs + 1, , drop = FALSE]

        ## so the true tox function is:
        thisTrueTox <- function(dose) {
          do.call(
            trueTox,
            ## First argument: the dose
            c(
              dose,
              ## Following arguments: take only those that
              ## are required by the tox function
              as.list(thisArgs)[trueToxArgnames]
            )
          )
        }

        ## and the true biomarker function is:
        thisTrueBiomarker <- function(dose) {
          do.call(
            trueBiomarker,
            ## First argument: the dose
            c(
              dose,
              ## Following arguments: take only those that
              ## are required by the biomarker function
              as.list(thisArgs)[trueBiomarkerArgnames]
            )
          )
        }

        ## start the simulated data with the provided one
        thisData <- object@data

        ## shall we stop the trial?
        ## First, we want to continue with the starting dose.
        ## This variable is updated after each cohort in the loop.
        stopit <- FALSE

        ## what is the next dose to be used?
        ## initialize with starting dose
        thisDose <- object@startingDose

        if (thisData@placebo) {
          ## what is the probability for tox. at placebo?
          thisProb.PL <- thisTrueTox(object@data@doseGrid[1])
          thisMeanZ.PL <- qlogis(thisProb.PL)

          ## what is the biomarker mean at placebo?
          thisMeanBiomarker.PL <- thisTrueBiomarker(object@data@doseGrid[1])
        }

        # In case there are placebo, extract true Toxicity and Efficacy for placebo

        ## inside this loop we simulate the whole trial, until stopping
        while (!stopit) {
          ## what is the probability for tox. at this dose?
          thisProb <- thisTrueTox(thisDose)
          ## and the transformation to the z scale is:
          thisMeanZ <- qlogis(thisProb)

          ## what is the biomarker mean at this dose?
          thisMeanBiomarker <- thisTrueBiomarker(thisDose)

          ## what is the cohort size at this dose?
          thisSize <- size(object@cohort_size,
            dose = thisDose,
            data = thisData
          )

          ## In case there are placebo
          ## what is the cohort size at this dose for Placebo?
          if (thisData@placebo) {
            thisSize.PL <- size(object@pl_cohort_size,
              dose = thisDose,
              data = thisData
            )
          }

          ## simulate tox and biomarker response: depends on whether we
          ## separate the first patient or not.
          tmp <-
            if (firstSeparate && (thisSize > 1L)) {
              ## dose the first patient
              tmpStart <- mvtnorm::rmvnorm(
                n = 1,
                mean =
                  c(
                    thisMeanBiomarker,
                    thisMeanZ
                  ),
                sigma = trueCov
              )

              if (thisData@placebo && (thisSize.PL > 0L)) {
                tmpStart.PL <- mvtnorm::rmvnorm(
                  n = 1,
                  mean =
                    c(
                      thisMeanBiomarker.PL,
                      thisMeanZ.PL
                    ),
                  sigma = trueCov
                )
              }


              ## if there is no DLT:
              if (tmpStart[, 2] < 0) {
                ## enroll the remaining patients
                tmpStart <-
                  rbind(
                    tmpStart,
                    mvtnorm::rmvnorm(
                      n = thisSize - 1,
                      mean =
                        c(
                          thisMeanBiomarker,
                          thisMeanZ
                        ),
                      sigma = trueCov
                    )
                  )

                if (thisData@placebo && (thisSize.PL > 0L)) {
                  tmpStart.PL <-
                    rbind(
                      tmpStart.PL,
                      mvtnorm::rmvnorm(
                        n = thisSize.PL,
                        mean =
                          c(
                            thisMeanBiomarker.PL,
                            thisMeanZ.PL
                          ),
                        sigma = trueCov
                      )
                    )
                }
              }

              if (thisData@placebo && (thisSize.PL > 0L)) {
                list(tmpStart = tmpStart, tmpStart.PL = tmpStart.PL)
              } else {
                list(tmpStart = tmpStart)
              }
            } else {
              ## we can directly dose all patients
              tmpStart <- mvtnorm::rmvnorm(
                n = thisSize,
                mean =
                  c(
                    thisMeanBiomarker,
                    thisMeanZ
                  ),
                sigma = trueCov
              )

              if (thisData@placebo && (thisSize.PL > 0L)) {
                tmpStart.PL <- mvtnorm::rmvnorm(
                  n = thisSize.PL,
                  mean =
                    c(
                      thisMeanBiomarker.PL,
                      thisMeanZ.PL
                    ),
                  sigma = trueCov
                )
              }

              if (thisData@placebo && (thisSize.PL > 0L)) {
                list(tmpStart = tmpStart, tmpStart.PL = tmpStart.PL)
              } else {
                list(tmpStart = tmpStart)
              }
            }

          ## extract biomarker and DLT samples
          thisBiomarkers <- tmp$tmpStart[, 1]
          thisDLTs <- as.integer(tmp$tmpStart[, 2] > 0)

          # in case there are placebo
          if (thisData@placebo && (thisSize.PL > 0L)) {
            thisBiomarkers.PL <- tmp$tmpStart.PL[, 1]
            thisDLTs.PL <- as.integer(tmp$tmpStart.PL[, 2] > 0)

            ## update the data first with placebo...
            thisData <- update(
              object = thisData,
              x = object@data@doseGrid[1],
              y = thisDLTs.PL,
              w = thisBiomarkers.PL,
              check = FALSE
            )

            ### ... and then with active dose
            thisData <- update(
              object = thisData,
              x = thisDose,
              y = thisDLTs,
              w = thisBiomarkers,
              new_cohort = FALSE
            )
          } else {
            thisData <- update(
              object = thisData,
              x = thisDose,
              y = thisDLTs,
              w = thisBiomarkers
            )
          }


          ## what is the dose limit?
          doselimit <- maxDose(object@increments,
            data = thisData
          )

          ## generate samples from the model
          thisSamples <- mcmc(
            data = thisData,
            model = object@model,
            options = mcmcOptions
          )

          ## => what is the next best dose?
          thisDose <- nextBest(object@nextBest,
            doselimit = doselimit,
            samples = thisSamples,
            model = object@model,
            data = thisData
          )$value

          ## evaluate stopping rules
          stopit <- stopTrial(object@stopping,
            dose = thisDose,
            samples = thisSamples,
            model = object@model,
            data = thisData
          )
          stopit_results <- h_unpack_stopit(stopit)
        }

        ## get the fit
        thisFit <- fit(
          object = thisSamples,
          model = object@model,
          data = thisData
        )

        # Get the MTD estimate from the samples.

        target_dose_samples <- dose(
          mean(object@nextBest@target),
          model = object@model,
          samples = thisSamples
        )

        # Create a function for additional statistical summary.

        additional_stats <- lapply(derive, function(f) f(target_dose_samples))


        ## return the results
        thisResult <-
          list(
            data = thisData,
            dose = thisDose,
            fitTox =
              subset(thisFit,
                select =
                  c(middle, lower, upper)
              ),
            fit_biomarker =
              subset(thisFit,
                select =
                  c(
                    middleBiomarker, lowerBiomarker,
                    upperBiomarker
                  )
              ),
            rho_est = median(thisSamples@data$rho),
            sigma2w_est = median(1 / thisSamples@data$precW),
            stop =
              attr(
                stopit,
                "message"
              ),
            additional_stats = additional_stats,
            report_results = stopit_results
          )

        return(thisResult)
      }

      resultList <- get_result_list(
        fun = runSim,
        nsim = nsim,
        vars =
          c(
            "simSeeds",
            "args",
            "nArgs",
            "firstSeparate",
            "trueTox",
            "trueBiomarker",
            "trueCov",
            "object",
            "mcmcOptions"
          ),
        parallel = parallel,
        n_cores = nCores
      )

      ## put everything in the Simulations format:

      ## setup the list for the simulated data objects
      dataList <- lapply(resultList, "[[", "data")

      ## the vector of the final dose recommendations
      recommendedDoses <- as.numeric(sapply(resultList, "[[", "dose"))

      ## vector of rho estimates
      rhoEstimates <- as.numeric(sapply(resultList, "[[", "rho_est"))

      ## vector of sigma2W estimates
      sigma2Westimates <- as.numeric(sapply(resultList, "[[", "sigma2w_est"))

      ## setup the list for the final tox fits
      fitToxList <- lapply(resultList, "[[", "fitTox")

      ## setup the list for the final biomarker fits
      fitBiomarkerList <- lapply(resultList, "[[", "fit_biomarker")

      ## the reasons for stopping
      stopReasons <- lapply(resultList, "[[", "stop")

      # individual stopping rule results as matrix, labels as column names
      stop_results <- lapply(resultList, "[[", "report_results")
      stop_report <- as.matrix(do.call(rbind, stop_results))

      ## For dual simulations summary of additional statistics.
      additional_stats <- lapply(resultList, "[[", "additional_stats")

      ## return the results in the DualSimulations class object
      ret <- DualSimulations(
        data = dataList,
        doses = recommendedDoses,
        rho_est = rhoEstimates,
        sigma2w_est = sigma2Westimates,
        fit = fitToxList,
        fit_biomarker = fitBiomarkerList,
        stop_report = stop_report,
        stop_reasons = stopReasons,
        additional_stats = additional_stats,
        seed = RNGstate
      )

      return(ret)
    }
)


## ============================================================

##' Obtain hypothetical trial course table for a design
##'
##' This generic function takes a design and generates a dataframe
##' showing the beginning of several hypothetical trial courses under
##' the design. This means, from the generated dataframe one can read off:
##' - how many cohorts are required in the optimal case (no DLTs observed) in
##'   order to reach the highest dose of the specified dose grid (or until
##'   the stopping rule is fulfilled)
##' - assuming no DLTs are observed until a certain dose level, what the next
##'   recommended dose is for all possible number of DLTs observed
##' - the actual relative increments that will be used in these cases
##' - whether the trial would stop at a certain cohort
##' Examining the "single trial" behavior of a dose escalation design is
##' the first important step in evaluating a design, and cannot be replaced by
##' studying solely the operating characteristics in "many trials". The cohort
##' sizes are also taken from the design, assuming no DLTs occur until the dose
##' listed.
##'
##' @param object the design (\code{\linkS4class{Design}} or
##' \code{\linkS4class{RuleDesign}} object) we want to examine
##' @param \dots additional arguments (see methods)
##' @param maxNoIncrement maximum number of contiguous next doses at 0
##' DLTs that are the same as before, i.e. no increment (default to 100)
##'
##' @return The data frame
##'
##' @export
##' @keywords methods regression
setGeneric("examine",
  def =
    function(object, ..., maxNoIncrement = 100L) {
      ## check maxNoIncrement argument
      assert_count(maxNoIncrement, positive = TRUE)

      ## there should be no default method,
      ## therefore just forward to next method!
      standardGeneric("examine")
    },
  valueClass = "data.frame"
)


##' @describeIn examine Examine a model-based CRM
##'
##' @param mcmcOptions object of class \code{\linkS4class{McmcOptions}},
##' giving the MCMC options for each evaluation in the trial. By default,
##' the standard options are used
##'
##' @example examples/design-method-examine-Design.R
setMethod("examine",
  signature =
    signature(object = "Design"),
  def =
    function(object,
             mcmcOptions = McmcOptions(),
             ...,
             maxNoIncrement) {
      ## start with the empty table
      ret <- data.frame(
        dose = numeric(),
        DLTs = integer(),
        nextDose = numeric(),
        stop = logical(),
        increment = integer()
      )

      ## start the base data with the provided one
      baseData <- object@data

      ## are we finished and can stop?
      stopit <- FALSE

      ## counter how many contiguous doses at 0 DLTs with
      ## no increment
      noIncrementCounter <- 0L

      ## what is the next dose to be used?
      ## initialize with starting dose
      thisDose <- object@startingDose

      ## inside this loop we continue filling up the table, until
      ## stopping
      while (!stopit) {
        ## what is the cohort size at this dose?
        thisSize <- size(object@cohort_size,
          dose = thisDose,
          data = baseData
        )

        if (baseData@placebo) {
          thisSize.PL <- size(object@pl_cohort_size,
            dose = thisDose,
            data = baseData
          )
        }

        ## for all possible number of DLTs:
        for (numDLTs in 0:thisSize)
        {
          ## update data with corresponding DLT vector
          if (baseData@placebo && (thisSize.PL > 0L)) {
            thisData <- update(
              object = baseData,
              x = baseData@doseGrid[1],
              y = rep(0, thisSize.PL),
              check = FALSE
            )

            thisData <-
              update(
                object = thisData,
                x = thisDose,
                y =
                  rep(
                    x = c(0, 1),
                    times =
                      c(
                        thisSize - numDLTs,
                        numDLTs
                      )
                  ),
                new_cohort = FALSE
              )
          } else {
            thisData <-
              update(
                object = baseData,
                x = thisDose,
                y =
                  rep(
                    x = c(0, 1),
                    times =
                      c(
                        thisSize - numDLTs,
                        numDLTs
                      )
                  )
              )
          }

          ## what is the dose limit?
          doselimit <- maxDose(object@increments,
            data = thisData
          )

          ## generate samples from the model
          thisSamples <- mcmc(
            data = thisData,
            model = object@model,
            options = mcmcOptions
          )

          ## => what is the next best dose?
          nextDose <- nextBest(object@nextBest,
            doselimit = doselimit,
            samples = thisSamples,
            model = object@model,
            data = thisData
          )$value

          ## compute relative increment in percent
          thisIncrement <-
            round((nextDose - thisDose) / thisDose * 100)

          ## evaluate stopping rules
          stopThisTrial <- stopTrial(object@stopping,
            dose = nextDose,
            samples = thisSamples,
            model = object@model,
            data = thisData
          )

          ## append information to the data frame
          ret <- rbind(
            ret,
            list(
              dose = thisDose,
              DLTs = numDLTs,
              nextDose = nextDose,
              stop = stopThisTrial,
              increment = as.integer(thisIncrement)
            )
          )
        }

        ## change base data
        if (baseData@placebo && (thisSize.PL > 0L)) {
          baseData <-
            update(
              object = baseData,
              x = baseData@doseGrid[1],
              y = rep(0, thisSize.PL),
              check = FALSE
            )

          baseData <-
            update(
              object = baseData,
              x = thisDose,
              y = rep(0, thisSize),
              new_cohort = FALSE
            )
        } else {
          baseData <-
            update(
              object = baseData,
              x = thisDose,
              y = rep(0, thisSize)
            )
        }

        ## what are the results if 0 DLTs?
        resultsNoDLTs <- subset(
          tail(ret, thisSize + 1),
          dose == thisDose & DLTs == 0
        )

        ## what is the new dose then accordingly?
        newDose <- as.numeric(resultsNoDLTs$nextDose)

        ## what is the difference to the previous dose?
        doseDiff <- newDose - thisDose

        ## update the counter for no increments of the dose
        if (doseDiff == 0) {
          noIncrementCounter <- noIncrementCounter + 1L
        } else {
          noIncrementCounter <- 0L
        }

        ## would stopping rule be fulfilled already?
        stopAlready <- resultsNoDLTs$stop

        ## update dose
        thisDose <- newDose

        ## too many times no increment?
        stopNoIncrement <- (noIncrementCounter >= maxNoIncrement)
        if (stopNoIncrement) {
          warning(paste(
            "Stopping because",
            noIncrementCounter,
            "times no increment vs. previous dose"
          ))
        }

        ## check if we can stop:
        ## either when we have reached the highest dose in the
        ## next cohort, or when the stopping rule is already
        ## fulfilled, or when too many times no increment
        stopit <- (thisDose >= max(object@data@doseGrid)) ||
          stopAlready || stopNoIncrement
      }

      return(ret)
    }
)



##' @describeIn examine Examine a rule-based design
##' @example examples/design-method-examine-RuleDesign.R
setMethod("examine",
  signature =
    signature(object = "RuleDesign"),
  def =
    function(object,
             ...,
             maxNoIncrement) {
      ## start with the empty table
      ret <- data.frame(
        dose = numeric(),
        DLTs = integer(),
        nextDose = numeric(),
        stop = logical(),
        increment = integer()
      )

      ## start the base data with the provided one
      baseData <- object@data

      ## are we finished and can stop?
      stopit <- FALSE

      ## counter how many contiguous doses at 0 DLTs with
      ## no increment
      noIncrementCounter <- 0L

      ## what is the next dose to be used?
      ## initialize with starting dose
      thisDose <- object@startingDose

      ## inside this loop we continue filling up the table, until
      ## stopping
      while (!stopit) {
        ## what is the cohort size at this dose?
        thisSize <- size(object@cohort_size,
          dose = thisDose,
          data = baseData
        )

        ## for all possible number of DLTs:
        for (numDLTs in 0:thisSize)
        {
          ## update data with corresponding DLT vector
          thisData <-
            update(
              object = baseData,
              x = thisDose,
              y =
                rep(
                  x = c(0, 1),
                  times =
                    c(
                      thisSize - numDLTs,
                      numDLTs
                    )
                )
            )

          ## evaluate the rule
          thisOutcome <- nextBest(object@nextBest,
            data = thisData
          )

          ## next dose
          nextDose <- thisOutcome$value

          ## do we stop here?
          stopThisTrial <- thisOutcome$stopHere

          ## compute relative increment in percent
          thisIncrement <-
            round((nextDose - thisDose) / thisDose * 100)

          ## append information to the data frame
          ret <- rbind(
            ret,
            list(
              dose = thisDose,
              DLTs = numDLTs,
              nextDose = nextDose,
              stop = stopThisTrial,
              increment = as.integer(thisIncrement)
            )
          )
        }

        ## change base data
        baseData <-
          update(
            object = baseData,
            x = thisDose,
            y = rep(0, thisSize)
          )

        ## what are the results if 0 DLTs?
        resultsNoDLTs <- subset(
          tail(ret, thisSize + 1),
          dose == thisDose & DLTs == 0
        )

        ## what is the new dose then accordingly?
        newDose <- as.numeric(resultsNoDLTs$nextDose)

        ## what is the difference to the previous dose?
        doseDiff <- newDose - thisDose

        ## update the counter for no increments of the dose
        if (doseDiff == 0) {
          noIncrementCounter <- noIncrementCounter + 1L
        } else {
          noIncrementCounter <- 0L
        }

        ## would stopping rule be fulfilled already?
        stopAlready <- resultsNoDLTs$stop

        ## update dose
        thisDose <- newDose

        ## too many times no increment?
        stopNoIncrement <- (noIncrementCounter >= maxNoIncrement)
        if (stopNoIncrement) {
          warning(paste(
            "Stopping because",
            noIncrementCounter,
            "times no increment vs. previous dose"
          ))
        }

        ## check if we can stop:
        ## either when we have reached the highest dose in the
        ## next cohort, or when the stopping rule is already
        ## fulfilled, or when too many times no increment
        stopit <- (thisDose >= max(object@data@doseGrid)) ||
          stopAlready || stopNoIncrement
      }

      return(ret)
    }
)

##' @describeIn examine Examine a model-based CRM
##'
##' @param mcmcOptions object of class \code{\linkS4class{McmcOptions}},
##' giving the MCMC options for each evaluation in the trial. By default,
##' the standard options are used
##'
##' @example examples/design-method-examine-DADesign.R
setMethod("examine",
  signature =
    signature(object = "DADesign"),
  def =
    function(object, mcmcOptions = McmcOptions(), ...,
             maxNoIncrement) {
      # A function to return follow up fulfull yes (TRUE) vs no (FALSE);
      ready_to_open <- function(day, window, thisSurv) {
        size <- length(thisSurv)
        # the date the patient starts;
        start_time <- apply(rbind(thisSurv[-size], window$patientGap[-1]), 2, min)
        # the relative time for each patient on the specified "date";
        individule_check <- day - cumsum(c(0, start_time))
        # the minial number should be 0;
        individule_check[individule_check < 0] <- 0
        follow_up <- apply(rbind(thisSurv, individule_check), 2, min)
        return(all((follow_up - apply(rbind(window$patientFollow, thisSurv), 2, min)) >= 0) & (max(follow_up) >= min(window$patientFollowMin, max(thisSurv))))
      }

      ## assume we have surfficient patients, i.e. patient can be immediately enrolled
      ## once the trial accumulation is open. This function will tell you when to open
      ## the next cohort;
      # this function applys to all trials;
      nextOpen <- function(window, thisSurv) {
        size <- length(thisSurv)

        window$patientGap <- window$patientGap[1:size] ## if length(window$pt)>length(thisSurv), assume the first length(thisSurv) patients were enrolled;
        ## if the DLT happens before the end of DLT window, then the next
        ## cohort/enrollment of the next patient would happened earlier;
        start_time <- apply(rbind(thisSurv[-size], window$patientGap[-1]), 2, min)
        # duration of the cohort (all DLT windows finished);
        maxT <- max(thisSurv + cumsum(c(0, start_time)))

        meetrequire <- sapply(1:maxT, function(i) {
          ready_to_open(i, window, thisSurv)
        })
        if (sum(meetrequire) > 0) {
          # the earliest time that the require is met;
          time <- min(c(1:maxT)[meetrequire])
        } else {
          time <- maxT
        }

        return(time)
      }

      ## start with the empty table
      ret <- data.frame(
        DLTsearly_1 = integer(), ## JZ: add a cohort index;
        dose = numeric(),
        DLTs = integer(),
        nextDose = numeric(),
        stop = logical(),
        increment = integer()
      )

      ## start the base data with the provided one
      baseData <- object@data

      ## are we finished and can stop?
      stopit <- FALSE

      ## what is the next dose to be used?
      ## initialize with starting dose
      thisDose <- object@startingDose

      ## initial {fact} variables;
      factDLTs <- baseData@y
      factSurv <- baseData@u
      factT0 <- baseData@t0

      ## Initiate "trialtime" which is zero. This is the global time for studies;
      trialtime <- 0

      ## when the current cohort open?
      pretime <- 0

      ## the duration of DLT window
      Tmax <- baseData@Tmax

      ## number of patients with un-completed DLT window;
      ## assume no patient is under DLT observation period at the beginning;
      preSize <- 0

      ## inside this loop we continue filling up the table, until
      ## stopping
      while (!stopit) {
        ## what is the cohort size at this dose?
        thisSize <- size(object@cohort_size,
          dose = thisDose,
          data = baseData
        )

        ## what's the safetywindow
        thisSafetywindow <- windowLength(object@safetyWindow, thisSize)


        # initial parameters
        thisT0 <- trialtime + cumsum(thisSafetywindow$patientGap)

        factDLTs <- c(factDLTs, rep(0, thisSize))

        factSurv <- c(factSurv, rep(Tmax, thisSize))

        factT0 <- c(factT0, thisT0)

        ## The time that the next cohort open
        trialtime <- trialtime + nextOpen(
          window = thisSafetywindow,
          thisSurv = rep(Tmax, thisSize)
        )

        ## In the DA-CRM, we should count the number of patients who is still within the DLT window;
        ## Thus the loop for numDLTs should be 0:nFollow;
        nFollow <- thisSize + preSize

        ## Identify the censored patients;
        ## "thiscensored" will be used in the cases that numDLTs>0;
        npt <- length(baseData@x) # total number of patients

        thiscensored <- c(c(1:npt)[(trialtime - baseData@t0) < baseData@Tmax & baseData@y == 0], (npt + 1):(npt + thisSize))



        ## for all possible number of DLTs:
        for (numDLTs in 0:nFollow)
        {
          ## If numDLTs>0, two extreme cases will be examinated;
          ## (1) DLTs occur on patients with the longer follow ups;
          ## (2) DLTs occur on patients with the shorter follow ups;






          if (numDLTs == 0) {
            baseData <- update(
              object = baseData,
              y = factDLTs, #### the x will be constantly updated according to u
              u = factSurv,
              t0 = factT0,
              x = thisDose,
              trialtime = trialtime
            ) #### the u will be constantly updated



            ## what is the dose limit?
            doselimit <- maxDose(object@increments,
              data = baseData
            )

            ## generate samples from the model
            thisSamples <- mcmc(
              data = baseData,
              model = object@model,
              options = mcmcOptions
            )

            ## => what is the next best dose?
            nextDose <- nextBest(object@nextBest,
              doselimit = doselimit,
              samples = thisSamples,
              model = object@model,
              data = baseData
            )$value

            # ##remove savePlot
            #
            #                                                   savePlot(plot(baseData),name=paste("Dose",thisDose,0,"DLT",nextDose,sep="_"))
            #
            ## compute relative increment in percent
            thisIncrement <-
              round((nextDose - thisDose) / thisDose * 100)

            ## evaluate stopping rules
            stopThisTrial <- stopTrial(object@stopping,
              dose = nextDose,
              samples = thisSamples,
              model = object@model,
              data = baseData
            )

            ## append information to the data frame
            ret <- rbind(
              ret,
              list(
                DLTsearly_1 = 0,
                dose = thisDose,
                DLTs = numDLTs,
                nextDose = nextDose,
                stop = stopThisTrial,
                increment = as.integer(thisIncrement)
              )
            )
            ### comment here to show only no DLTs;
            #                                            }
          } else {
            for (DLTsearly in 1:numDLTs) {
              # Update current {fact} variables
              thisDLTs <- factDLTs
              thisSurv <- factSurv

              if (DLTsearly == 1) {
                # scenario 1: The patients with longest follow up have DLTs

                thisDLTs[thiscensored][1:numDLTs] <- rep(1, rep(numDLTs))

                thisSurv[thiscensored][1:numDLTs] <- apply(rbind(rep(Tmax, numDLTs), c(trialtime - factT0[thiscensored][1:numDLTs])), 2, min)


                thisData <- update(
                  object = baseData,
                  y = thisDLTs, #### the y will be updated according to u
                  u = thisSurv,
                  t0 = factT0,
                  x = thisDose,
                  trialtime = trialtime
                ) #### the u will be updated
              } else {
                # scenario 2: The patients with shortest follow up have DLTs

                thisDLTs[rev(thiscensored)][1:numDLTs] <- rep(1, rep(numDLTs))

                thisSurv[rev(thiscensored)][1:numDLTs] <- c(apply(rbind(rep(1, numDLTs), pretime + 1 - factT0[rev(thiscensored)][1:numDLTs]), 2, max))

                if (numDLTs >= thisSize) {
                  thistime <- 1 + max(thisT0)
                } else {
                  thistime <- trialtime
                }

                thisData <- update(
                  object = baseData,
                  y = thisDLTs, #### the y will be updated according to u
                  u = thisSurv,
                  t0 = factT0,
                  x = thisDose,
                  trialtime = thistime
                ) #### the u will be updated
              }


              ## what is the dose limit?
              doselimit <- maxDose(object@increments,
                data = thisData
              )

              ## generate samples from the model
              thisSamples <- mcmc(
                data = thisData,
                model = object@model,
                options = mcmcOptions
              )

              ## => what is the next best dose?
              nextDose <- nextBest(object@nextBest,
                doselimit = doselimit,
                samples = thisSamples,
                model = object@model,
                data = thisData
              )$value

              # ##remove savePlot
              #                                                   savePlot(plot(thisData),name=paste("Dose",thisDose,numDLTs,"DLT",DLTsearly,nextDose,sep="_"))
              #
              ## compute relative increment in percent
              thisIncrement <-
                round((nextDose - thisDose) / thisDose * 100)

              ## evaluate stopping rules
              stopThisTrial <- stopTrial(object@stopping,
                dose = nextDose,
                samples = thisSamples,
                model = object@model,
                data = thisData
              )

              ## append information to the data frame
              ret <- rbind(
                ret,
                list(
                  DLTsearly_1 = DLTsearly,
                  dose = thisDose,
                  DLTs = numDLTs,
                  nextDose = nextDose,
                  stop = stopThisTrial,
                  increment = as.integer(thisIncrement)
                )
              )
            }
          }
        }

        ## update pretime
        pretime <- trialtime

        ## what are the results if 0 DLTs?
        resultsNoDLTs <- subset(
          ret,
          dose == thisDose & DLTs == 0
        )

        ## what is the new dose according to table?
        newDose <- as.numeric(resultsNoDLTs$nextDose)

        ## what is the difference to the previous dose?
        doseDiff <- newDose - thisDose

        ## would stopping rule be fulfilled already?
        stopAlready <- any(resultsNoDLTs$stop)

        ## update dose
        thisDose <- max(newDose)

        ## number of patients with un-completed DLT window;
        preSize <- sum(baseData@u[baseData@y == 0] < baseData@Tmax)

        ## update the counter for no increments of the dose
        if (all(doseDiff == 0)) {
          noIncrementCounter <- noIncrementCounter + 1L
        } else {
          noIncrementCounter <- 0L
        }

        ## too many times no increment?
        stopNoIncrement <- (noIncrementCounter >= maxNoIncrement)
        if (stopNoIncrement) {
          warning(paste(
            "Stopping because",
            noIncrementCounter,
            "times no increment vs. previous dose"
          ))
        }

        ## check if we can stop:
        ## either when we have reached the highest dose in the
        ## next cohort, or when the stopping rule is already
        ## fulfilled, or when too many times no increment
        stopit <- (thisDose >= max(object@data@doseGrid)) ||
          stopAlready || stopNoIncrement
      }

      return(ret)
    }
)

## ===================================================================================
## ----------------------------------------------------------------------------------------
##  Simulate design using DLE responses only with DLE samples (pseudo DLE model)
## ------------------------------------------------------------------------------------
##' This is a methods to simulate dose escalation procedure only using the DLE responses.
##' This is a method based on the \code{\linkS4class{TDsamplesDesign}} where model used are of
##' \code{\linkS4class{ModelTox}} class object DLE samples are also used
##'
##' @param object the \code{\linkS4class{TDsamplesDesign}} object we want to simulate the data from
##' @param nsim the number of simulations (default :1)
##' @param seed see \code{\link{set_seed}}
##' @param truth a function which takes as input a dose (vector) and returns the true probability
##' (vector) of the occurrence of a DLE. Additional arguments can be supplied in \code{args}.
##' @param args data frame with arguments for the \code{truth} function. The
##' column names correspond to the argument names, the rows to the values of the
##' arguments. The rows are appropriately recycled in the \code{nsim}
##' simulations. In order to produce outcomes from the posterior predictive
##' distribution, e.g, pass an \code{object} that contains the data observed so
##' far, \code{truth} contains the \code{prob} function from the model in
##' \code{object}, and \code{args} contains posterior samples from the model.
##' @param firstSeparate enroll the first patient separately from the rest of
##' the cohort? (not default) If yes, the cohort will be closed if a DLT occurs
##' in this patient.
##' @param mcmcOptions object of class \code{\linkS4class{McmcOptions}},
##' giving the MCMC options for each evaluation in the trial. By default,
##' the standard options are used
##' @param parallel should the simulation runs be parallelized across the
##' clusters of the computer? (not default)
##' @param nCores how many cores should be used for parallel computing?
##' Defaults to the number of cores on the machine, maximum 5.
##' @param \dots not used
##'
##' @example examples/design-method-simulateTDsamplesDesign.R
##'
##' @return an object of class \code{\linkS4class{PseudoSimulations}}
##'
##'  @export
##'  @keywords methods
setMethod("simulate",
  signature =
    signature(
      object = "TDsamplesDesign",
      nsim = "ANY",
      seed = "ANY"
    ),
  def =
    function(object, nsim = 1L, seed = NULL,
             truth, args = NULL, firstSeparate = FALSE,
             mcmcOptions = McmcOptions(),
             parallel = FALSE, nCores =
               min(parallel::detectCores(), 5L),
             ...) {
      ## checks and extracts
      assert_function(truth)
      assert_flag(firstSeparate)
      assert_count(nsim, positive = TRUE)
      assert_flag(parallel)
      assert_count(nCores, positive = TRUE)

      args <- as.data.frame(args)
      nArgs <- max(nrow(args), 1L)


      ## seed handling
      RNGstate <- set_seed(seed)

      ## from this,
      ## generate the individual seeds for the simulation runs
      simSeeds <- sample(x = seq_len(1e5), size = as.integer(nsim))

      ## the function to produce the run a single simulation
      ## with index "iterSim"
      runSim <- function(iterSim) {
        ## set the seed for this run
        set.seed(simSeeds[iterSim])

        ## what is now the argument for the truth?
        ## (appropriately recycled)
        thisArgs <- args[(iterSim - 1) %% nArgs + 1, , drop = FALSE]

        ## so this truth is...
        thisTruth <- function(dose) {
          do.call(
            truth,
            ## First argument: the dose
            c(
              dose,
              ## Following arguments
              thisArgs
            )
          )
        }

        ## start the simulated data with the provided one
        thisData <- object@data

        # In case there are placebo
        if (thisData@placebo) {
          ## what is the probability for tox. at placebo?
          thisProb.PL <- thisTruth(object@data@doseGrid[1])
        }


        ## shall we stop the trial?
        ## First, we want to continue with the starting dose.
        ## This variable is updated after each cohort in the loop.
        stopit <- FALSE

        ## what is the next dose to be used?
        ## initialize with starting dose
        thisDose <- object@startingDose

        ## inside this loop we simulate the whole trial, until stopping
        while (!stopit) {
          ## what is the probability for tox. at this dose?
          thisProb <- thisTruth(thisDose)


          ## what is the cohort size at this dose?
          thisSize <- size(object@cohort_size,
            dose = thisDose,
            data = thisData
          )

          ## In case there are placebo
          if (thisData@placebo) {
            thisSize.PL <- size(object@pl_cohort_size,
              dose = thisDose,
              data = thisData
            )
          }



          ## simulate DLTs: depends on whether we
          ## separate the first patient or not.
          if (firstSeparate && (thisSize > 1L)) {
            ## dose the first patient
            thisDLTs <- rbinom(
              n = 1L,
              size = 1L,
              prob = thisProb
            )

            if (thisData@placebo && (thisSize.PL > 0L)) {
              thisDLTs.PL <- rbinom(
                n = 1L,
                size = 1L,
                prob = thisProb.PL
              )
            }

            ## if there is no DLT:
            if (thisDLTs == 0) {
              ## enroll the remaining patients
              thisDLTs <- c(
                thisDLTs,
                rbinom(
                  n = thisSize - 1L,
                  size = 1L,
                  prob = thisProb
                )
              )

              if (thisData@placebo && (thisSize.PL > 0L)) {
                thisDLTs.PL <- c(
                  thisDLTs.PL,
                  rbinom(
                    n = thisSize.PL,
                    size = 1L,
                    prob = thisProb.PL
                  )
                )
              }
            }
          } else {
            ## we can directly dose all patients
            thisDLTs <- rbinom(
              n = thisSize,
              size = 1L,
              prob = thisProb
            )
            if (thisData@placebo && (thisSize.PL > 0L)) {
              thisDLTs.PL <- rbinom(
                n = thisSize.PL,
                size = 1L,
                prob = thisProb.PL
              )
            }
          }

          ## update the data with this placebo (if any) cohort and then with active dose
          if (thisData@placebo && (thisSize.PL > 0L)) {
            thisData <- update(
              object = thisData,
              x = object@data@doseGrid[1],
              y = thisDLTs.PL
            )

            ## update the data with active dose
            thisData <- update(
              object = thisData,
              x = thisDose,
              y = thisDLTs,
              new_cohort = FALSE
            )
          } else {
            ## update the data with this cohort
            thisData <- update(
              object = thisData,
              x = thisDose,
              y = thisDLTs
            )
          }

          ## Update the model with thisData
          thisModel <- update(object@model,
            data = thisData
          )

          ## what is the dose limit?
          doselimit <- maxDose(object@increments,
            data = thisData
          )

          ## generate samples from the model
          thisSamples <- mcmc(
            data = thisData,
            model = thisModel,
            options = mcmcOptions
          )

          ## => what is the next best dose?

          next_bd <- nextBest(object@nextBest,
            doselimit = doselimit,
            samples = thisSamples,
            model = thisModel,
            data = thisData,
            in_sim = TRUE
          )

          thisDose <- next_bd$next_dose_drt
          thisTDtargetDuringTrial <- next_bd$dose_target_drt
          thisTDtargetEndOfTrial <- next_bd$dose_target_eot
          thisTDtargetEndOfTrialatdoseGrid <- next_bd$next_dose_eot
          thisCITDEOT <- list(lower = next_bd$ci_dose_target_eot[1], upper = next_bd$ci_dose_target_eot[2])
          thisratioTDEOT <- next_bd$ci_ratio_dose_target_eot

          ## evaluate stopping rules
          stopit <- stopTrial(object@stopping,
            dose = thisDose,
            samples = thisSamples,
            model = thisModel,
            data = thisData
          )
          stopit_results <- h_unpack_stopit(stopit)
        }

        ## get the fit
        thisFit <- fit(
          object = thisSamples,
          model = thisModel,
          data = thisData
        )


        ## return the results
        thisResult <-
          list(
            data = thisData,
            dose = thisDose,
            TDtargetDuringTrial = thisTDtargetDuringTrial,
            TDtargetEndOfTrial = thisTDtargetEndOfTrial,
            TDtargetEndOfTrialatdoseGrid = thisTDtargetEndOfTrialatdoseGrid,
            TDtargetDuringTrialatdoseGrid = thisDose,
            CITDEOT = thisCITDEOT,
            ratioTDEOT = thisratioTDEOT,
            fit =
              subset(thisFit,
                select = c(middle, lower, upper)
              ),
            stop =
              attr(
                stopit,
                "message"
              ),
            report_results = stopit_results
          )
        return(thisResult)
      }

      resultList <- get_result_list(
        fun = runSim,
        nsim = nsim,
        vars =
          c(
            "simSeeds",
            "args",
            "nArgs",
            "firstSeparate",
            "truth",
            "object",
            "mcmcOptions"
          ),
        parallel = parallel,
        n_cores = nCores
      )

      ## put everything in the Simulations format:

      ## setup the list for the simulated data objects
      dataList <- lapply(resultList, "[[", "data")

      ## set up list for the final TD during Trial Estimate
      TDtargetDuringTrialList <- as.numeric(sapply(resultList, "[[", "TDtargetDuringTrial"))

      ## set up list for the final TD End of Trial Estimate
      TDtargetEndOfTrialList <- as.numeric(sapply(resultList, "[[", "TDtargetEndOfTrial"))

      ## set up list for the final TD during Trial estimate at dose Grid
      TDtargetDuringTrialDoseGridList <- as.numeric(sapply(resultList, "[[", "TDtargetDuringTrialatdoseGrid"))

      ## set up list for the final TD End Of Trial estimate at dose Grid
      TDtargetEndOfTrialDoseGridList <- as.numeric(sapply(resultList, "[[", "TDtargetEndOfTrialatdoseGrid"))


      ## the vector of the final dose recommendations
      recommendedDoses <- as.numeric(sapply(resultList, "[[", "TDtargetEndOfTrialatdoseGrid"))

      ## Set up the list for the final 95% CI obtained
      CIList <- lapply(resultList, "[[", "CITDEOT")

      ## Set up the list for the final ratios obtained
      ratioList <- as.numeric(sapply(resultList, "[[", "ratioTDEOT"))

      ## Set up the list for the final TDEOT 95% CI obtained
      CITDEOTList <- lapply(resultList, "[[", "CITDEOT")

      ## Set up the list for the final TDEOT ratios obtained
      ratioTDEOTList <- as.numeric(sapply(resultList, "[[", "ratioTDEOT"))

      ## setup the list for the final fits
      fitList <- lapply(resultList, "[[", "fit")

      ## the reasons for stopping
      stopReasons <- lapply(resultList, "[[", "stop")

      # individual stopping rule results as matrix, labels as column names
      stop_results <- lapply(resultList, "[[", "report_results")
      stop_report <- as.matrix(do.call(rbind, stop_results))


      ## return the results in the Simulations class object
      ret <- PseudoSimulations(
        data = dataList,
        doses = recommendedDoses,
        fit = fitList,
        FinalTDtargetDuringTrialEstimates = TDtargetDuringTrialList,
        FinalTDtargetEndOfTrialEstimates = TDtargetEndOfTrialList,
        FinalTDtargetDuringTrialAtDoseGrid = TDtargetDuringTrialDoseGridList,
        FinalTDtargetEndOfTrialAtDoseGrid = TDtargetEndOfTrialDoseGridList,
        FinalCIs = CIList,
        FinalRatios = ratioList,
        FinalTDEOTCIs = CITDEOTList,
        FinalTDEOTRatios = ratioTDEOTList,
        stopReasons = stopReasons,
        stop_report = stop_report,
        seed = RNGstate
      )

      return(ret)
    }
)
## -------------------------------------------------------------------------------------
## Simulate design using DLE responses only without samples (pseudo DLE model)
## --------------------------------------------------------------------------------
###
##' This is a methods to simulate dose escalation procedure only using the DLE responses.
##' This is a method based on the \code{\linkS4class{TDDesign}} where model used are of
##' \code{\linkS4class{ModelTox}} class object and no samples are involved.
##'
##' @param object the \code{\linkS4class{TDDesign}} object we want to simulate the data from
##' @param nsim the number of simulations (default :1)
##' @param seed see \code{\link{set_seed}}
##' @param truth a function which takes as input a dose (vector) and returns the true probability
##' (vector) of the occurrence of a DLE. Additional arguments can be supplied in \code{args}.
##' @param args data frame with arguments for the \code{truth} function. The
##' column names correspond to the argument names, the rows to the values of the
##' arguments. The rows are appropriately recycled in the \code{nsim}
##' simulations. In order to produce outcomes from the posterior predictive
##' distribution, e.g, pass an \code{object} that contains the data observed so
##' far, \code{truth} contains the \code{prob} function from the model in
##' \code{object}, and \code{args} contains posterior samples from the model.
##' @param firstSeparate enroll the first patient separately from the rest of
##' the cohort? (not default) If yes, the cohort will be closed if a DLT occurs
##' in this patient.
##' @param parallel should the simulation runs be parallelized across the
##' clusters of the computer? (not default)
##' @param nCores how many cores should be used for parallel computing?
##' Defaults to the number of cores on the machine, maximum 5.
##' @param \dots not used
##'
##' @example examples/design-method-simulateTDDesign.R
##'
##' @return an object of class \code{\linkS4class{PseudoSimulations}}
##'
##'  @export
##'  @keywords methods
setMethod("simulate",
  signature =
    signature(
      object = "TDDesign",
      nsim = "ANY",
      seed = "ANY"
    ),
  def =
    function(object, nsim = 1L, seed = NULL,
             truth, args = NULL, firstSeparate = FALSE,
             parallel = FALSE, nCores =
               min(parallel::detectCores(), 5L),
             ...) {
      ## checks and extracts
      assert_function(truth)
      assert_flag(firstSeparate)
      assert_count(nsim, positive = TRUE)
      assert_flag(parallel)
      assert_count(nCores, positive = TRUE)

      args <- as.data.frame(args)
      nArgs <- max(nrow(args), 1L)

      ## seed handling
      RNGstate <- set_seed(seed)

      ## from this,
      ## generate the individual seeds for the simulation runs
      simSeeds <- sample(x = seq_len(1e5), size = as.integer(nsim))

      ## the function to produce the run a single simulation
      ## with index "iterSim"
      runSim <- function(iterSim) {
        ## set the seed for this run
        set.seed(simSeeds[iterSim])

        ## what is now the argument for the truth?
        ## (appropriately recycled)
        thisArgs <- args[(iterSim - 1) %% nArgs + 1, , drop = FALSE]

        ## so this truth is...
        thisTruth <- function(dose) {
          do.call(
            truth,
            ## First argument: the dose
            c(
              dose,
              ## Following arguments
              thisArgs
            )
          )
        }

        ## start the simulated data with the provided one
        thisData <- object@data

        # In case there are placebo
        if (thisData@placebo) {
          ## what is the probability for tox. at placebo?
          thisProb.PL <- thisTruth(object@data@doseGrid[1])
        }

        ## shall we stop the trial?
        ## First, we want to continue with the starting dose.
        ## This variable is updated after each cohort in the loop.
        stopit <- FALSE

        ## what is the next dose to be used?
        ## initialize with starting dose
        thisDose <- object@startingDose

        ## inside this loop we simulate the whole trial, until stopping
        while (!stopit) {
          ## what is the probability for tox. at this dose?
          thisProb <- thisTruth(thisDose)

          ## what is the cohort size at this dose?
          thisSize <- size(object@cohort_size,
            dose = thisDose,
            data = thisData
          )

          ## In case there are placebo
          if (thisData@placebo) {
            thisSize.PL <- size(object@pl_cohort_size,
              dose = thisDose,
              data = thisData
            )
          }

          ## simulate DLTs: depends on whether we
          ## separate the first patient or not.
          if (firstSeparate && (thisSize > 1L)) {
            ## dose the first patient
            thisDLTs <- rbinom(
              n = 1L,
              size = 1L,
              prob = thisProb
            )

            if (thisData@placebo && (thisSize.PL > 0L)) {
              thisDLTs.PL <- rbinom(
                n = 1L,
                size = 1L,
                prob = thisProb.PL
              )
            }

            ## if there is no DLT:
            if (thisDLTs == 0) {
              ## enroll the remaining patients
              thisDLTs <- c(
                thisDLTs,
                rbinom(
                  n = thisSize - 1L,
                  size = 1L,
                  prob = thisProb
                )
              )

              if (thisData@placebo && (thisSize.PL > 0L)) {
                thisDLTs.PL <- c(
                  thisDLTs.PL,
                  rbinom(
                    n = thisSize.PL,
                    size = 1L,
                    prob = thisProb.PL
                  )
                )
              }
            }
          } else {
            ## we can directly dose all patients
            thisDLTs <- rbinom(
              n = thisSize,
              size = 1L,
              prob = thisProb
            )

            if (thisData@placebo && (thisSize.PL > 0L)) {
              thisDLTs.PL <- rbinom(
                n = thisSize.PL,
                size = 1L,
                prob = thisProb.PL
              )
            }
          }

          ## update the data with this placebo (if any) cohort and then with active dose
          if (thisData@placebo && (thisSize.PL > 0L)) {
            thisData <- update(
              object = thisData,
              x = object@data@doseGrid[1],
              y = thisDLTs.PL
            )

            ## update the data with active dose
            thisData <- update(
              object = thisData,
              x = thisDose,
              y = thisDLTs,
              new_cohort = FALSE
            )
          } else {
            ## update the data with this cohort
            thisData <- update(
              object = thisData,
              x = thisDose,
              y = thisDLTs
            )
          }

          ## Update model estimates with thisData
          thisModel <- update(object@model,
            data = thisData
          )

          ## what is the dose limit?
          doselimit <- maxDose(object@increments, data = thisData)


          ## => what is the next best dose?
          next_bd <- nextBest(object@nextBest,
            doselimit = doselimit,
            model = thisModel,
            data = thisData,
            in_sim = TRUE
          )

          thisDose <- next_bd$next_dose_drt
          thisTDtargetDuringTrial <- next_bd$dose_target_drt
          thisTDtargetEndOfTrial <- next_bd$dose_target_eot
          thisTDtargetEndOfTrialatdoseGrid <- next_bd$next_dose_eot
          thisCITDEOT <- list(lower = next_bd$ci_dose_target_eot[1], upper = next_bd$ci_dose_target_eot[2])
          thisratioTDEOT <- next_bd$ci_ratio_dose_target_eot

          ## evaluate stopping rules
          stopit <- stopTrial(object@stopping,
            dose = thisDose,
            model = thisModel,
            data = thisData
          )
          stopit_results <- h_unpack_stopit(stopit)
        }
        ## get the fit
        prob_fun <- probFunction(thisModel, phi1 = thisModel@phi1, phi2 = thisModel@phi2)
        thisFit <- list(
          phi1 = thisModel@phi1,
          phi2 = thisModel@phi2,
          probDLE = prob_fun(object@data@doseGrid)
        )



        ## return the results
        thisResult <-
          list(
            data = thisData,
            dose = thisDose,
            TDtargetDuringTrial = thisTDtargetDuringTrial,
            TDtargetEndOfTrial = thisTDtargetEndOfTrial,
            TDtargetEndOfTrialatdoseGrid = thisTDtargetEndOfTrialatdoseGrid,
            TDtargetDuringTrialatdoseGrid = thisDose,
            CITDEOT = thisCITDEOT,
            ratioTDEOT = thisratioTDEOT,
            fit = thisFit,
            stop =
              attr(
                stopit,
                "message"
              ),
            report_results = stopit_results
          )
        return(thisResult)
      }


      resultList <- get_result_list(
        fun = runSim,
        nsim = nsim,
        vars =
          c(
            "simSeeds",
            "args",
            "nArgs",
            "firstSeparate",
            "truth",
            "object"
          ),
        parallel = parallel,
        n_cores = nCores
      )

      ## put everything in the Simulations format:

      ## setup the list for the simulated data objects
      dataList <- lapply(resultList, "[[", "data")


      ## set up list for the final TD during Trial Estimate
      TDtargetDuringTrialList <- as.numeric(sapply(resultList, "[[", "TDtargetDuringTrial"))

      ## set up list for the final TD End of Trial Estimate
      TDtargetEndOfTrialList <- as.numeric(sapply(resultList, "[[", "TDtargetEndOfTrial"))

      ## set up list for the final TD during Trial estimate at dose Grid
      TDtargetDuringTrialDoseGridList <- as.numeric(sapply(resultList, "[[", "TDtargetDuringTrialatdoseGrid"))

      ## set up list for the final TD End Of Trial estimate at dose Grid
      TDtargetEndOfTrialDoseGridList <- as.numeric(sapply(resultList, "[[", "TDtargetEndOfTrialatdoseGrid"))


      ## the vector of the final dose recommendations
      recommendedDoses <- as.numeric(sapply(resultList, "[[", "TDtargetEndOfTrialatdoseGrid"))

      ## Set up the list for the final 95% CI obtained
      CIList <- lapply(resultList, "[[", "CITDEOT")

      ## Set up the list for the final ratios obtained
      ratioList <- as.numeric(sapply(resultList, "[[", "ratioTDEOT"))

      ## Set up the list for the final TDEOT 95% CI obtained
      CITDEOTList <- lapply(resultList, "[[", "CITDEOT")

      ## Set up the list for the final TDEOT ratios obtained
      ratioTDEOTList <- as.numeric(sapply(resultList, "[[", "ratioTDEOT"))
      ## set up the list for the final fits

      fitList <- lapply(resultList, "[[", "fit")

      ## the reasons for stopping
      stopReasons <- lapply(resultList, "[[", "stop")

      # individual stopping rule results as matrix, labels as column names
      stop_results <- lapply(resultList, "[[", "report_results")
      stop_report <- as.matrix(do.call(rbind, stop_results))


      ## return the results in the Simulations class object
      ret <- PseudoSimulations(
        data = dataList,
        doses = recommendedDoses,
        fit = fitList,
        FinalTDtargetDuringTrialEstimates = TDtargetDuringTrialList,
        FinalTDtargetEndOfTrialEstimates = TDtargetEndOfTrialList,
        FinalTDtargetDuringTrialAtDoseGrid = TDtargetDuringTrialDoseGridList,
        FinalTDtargetEndOfTrialAtDoseGrid = TDtargetEndOfTrialDoseGridList,
        FinalCIs = CIList,
        FinalRatios = ratioList,
        FinalTDEOTCIs = CITDEOTList,
        FinalTDEOTRatios = ratioTDEOTList,
        stopReasons = stopReasons,
        stop_report = stop_report,
        seed = RNGstate
      )

      return(ret)
    }
)
## -----------------------------------------------------------------------------------------------
## Simulate design using DLE and efficacy responses without DLE and efficacy samples (pseudo models)
## --------------------------------------------------------------------------------------------
###
##' This is a methods to simulate dose escalation procedure using both DLE and efficacy responses.
##' This is a method based on the \code{\linkS4class{DualResponsesDesign}} where DLEmodel used are of
##' \code{\linkS4class{ModelTox}} class object and efficacy model used are of \code{\linkS4class{ModelEff}}
##' class object. In addition, no DLE and efficacy samples are involved or generated in the simulation
##' process
##'
##' @param object the \code{\linkS4class{DualResponsesDesign}} object we want to simulate the data from
##' @param nsim the number of simulations (default :1)
##' @param seed see \code{\link{set_seed}}
##' @param trueDLE a function which takes as input a dose (vector) and returns the true probability
##' (vector) of the occurrence of a DLE. Additional arguments can be supplied in \code{args}.
##' @param trueEff a function which takes as input a dose (vector) and returns the expected efficacy
##' responses (vector). Additional arguments can be supplied in \code{args}.
##' @param trueNu the precision, the inverse of the variance of the efficacy responses
##' @param args data frame with arguments for the \code{trueDLE} and
##' \code{trueEff} function. The column names correspond to the argument
##' names, the rows to the values of the arguments. The rows are appropriately
##' recycled in the \code{nsim} simulations.
##' @param firstSeparate enroll the first patient separately from the rest of
##' the cohort? (not default) If yes, the cohort will be closed if a DLT occurs
##' in this patient.
##' @param parallel should the simulation runs be parallelized across the
##' clusters of the computer? (not default)
##' @param nCores how many cores should be used for parallel computing?
##' Defaults to the number of cores on the machine, maximum 5.
##' @param \dots not used
##'
##' @example examples/design-method-simulateDualResponsesDesign.R
##'
##' @return an object of class \code{\linkS4class{PseudoDualSimulations}}
##'
##' @export
##' @keywords methods

setMethod("simulate",
  signature =
    signature(
      object = "DualResponsesDesign",
      nsim = "ANY",
      seed = "ANY"
    ),
  def =
    function(object, nsim = 1L, seed = NULL,
             trueDLE, trueEff, trueNu,
             args = NULL, firstSeparate = FALSE,
             parallel = FALSE, nCores =
               min(parallel::detectCores(), 5L),
             ...) {
      ## checks and extracts
      assert_function(trueDLE)
      assert_function(trueEff)
      assert_true(trueNu > 0)
      assert_flag(firstSeparate)
      assert_count(nsim, positive = TRUE)
      assert_flag(parallel)
      assert_count(nCores, positive = TRUE)

      args <- as.data.frame(args)
      nArgs <- max(nrow(args), 1L)

      ## get names of arguments (excluding the first one which is the dose)
      trueDLEArgnames <- names(formals(trueDLE))[-1]
      trueEffArgnames <- names(formals(trueEff))[-1]



      ## seed handling
      RNGstate <- set_seed(seed)

      ## from this,
      ## generate the individual seeds for the simulation runs
      simSeeds <- sample(x = seq_len(1e5), size = as.integer(nsim))

      ## the function to produce the run a single simulation
      ## with index "iterSim"
      runSim <- function(iterSim) {
        ## set the seed for this run
        set.seed(simSeeds[iterSim])

        ## what is now the argument for the truth?
        ## (appropriately recycled)
        thisArgs <- args[(iterSim - 1) %% nArgs + 1, , drop = FALSE]

        ## so this truth DLE function is...
        thisTruthDLE <- function(dose) {
          do.call(
            trueDLE,
            ## First argument: the dose
            c(
              dose,
              ## Following arguments: take only those that
              ## are required by the DLE function
              as.list(thisArgs)[trueDLEArgnames]
            )
          )
        }

        ## and the truth Eff function is:
        thisTruthEff <- function(dose) {
          do.call(
            trueEff,
            ## First argument: the dose
            c(
              dose,
              ## Following arguments: take only those that
              ## are required by the Eff function
              as.list(thisArgs)[trueEffArgnames]
            )
          )
        }

        ## start the simulated data with the provided one
        thisData <- object@data

        ## find true sigma2 to generate responses

        trueSigma2 <- 1 / trueNu

        ## start the simulated data with the provided one
        thisData <- object@data

        if (thisData@placebo) {
          ## what is the probability for tox. at placebo?
          thisProb.PL <- thisTruthDLE(object@data@doseGrid[1])

          ## what is the mean efficacy at placebo?
          thisMeanEff.PL <- thisTruthEff(object@data@doseGrid[1])
        }

        ## shall we stop the trial?
        ## First, we want to continue with the starting dose.
        ## This variable is updated after each cohort in the loop.
        stopit <- FALSE

        ## what is the next dose to be used?
        ## initialize with starting dose
        thisDose <- object@startingDose

        ## inside this loop we simulate the whole trial, until stopping
        while (!stopit) {
          ## what is the probability for tox. at this dose?
          thisDLEProb <- thisTruthDLE(thisDose)
          thisMeanEff <- thisTruthEff(thisDose)

          ## what is the cohort size at this dose?
          thisSize <- size(object@cohort_size,
            dose = thisDose,
            data = thisData
          )


          ## In case there are placebo
          ## what is the cohort size at this dose for Placebo?
          if (thisData@placebo) {
            thisSize.PL <- size(object@pl_cohort_size,
              dose = thisDose,
              data = thisData
            )
          }


          ## simulate DLTs: depends on whether we
          ## separate the first patient or not.
          if (firstSeparate && (thisSize > 1L)) {
            ## dose the first patient
            thisDLTs <- rbinom(
              n = 1L,
              size = 1L,
              prob = thisDLEProb
            )


            if (thisData@placebo && (thisSize.PL > 0L)) {
              thisDLTs.PL <- rbinom(
                n = 1L,
                size = 1L,
                prob = thisProb.PL
              )
            }

            thisEff <- rnorm(
              n = 1L,
              mean = thisMeanEff,
              sd = sqrt(trueSigma2)
            )

            if (thisData@placebo && (thisSize.PL > 0L)) {
              thisEff.PL <- rnorm(
                n = 1L,
                mean = thisMeanEff.PL,
                sd = sqrt(trueSigma2)
              )
            }

            ## if there is no DLT:
            if (thisDLTs == 0) {
              ## enroll the remaining patients
              thisDLTs <- c(
                thisDLTs,
                rbinom(
                  n = thisSize - 1L,
                  size = 1L,
                  prob = thisDLEProb
                )
              )

              thisEff <- c(
                thisEff,
                rnorm(
                  n = thisSize - 1L,
                  mean = thisMeanEff,
                  sd = sqrt(trueSigma2)
                )
              )

              if (thisData@placebo && (thisSize.PL > 0L)) {
                thisDLTs.PL <- c(
                  thisDLTs.PL,
                  rbinom(
                    n = thisSize.PL,
                    size = 1L,
                    prob = thisProb.PL
                  )
                )
                thisEff.PL <- c(
                  thisMeanEff.PL,
                  rnorm(
                    n = thisSize.PL,
                    mean = thisMeanEff.PL,
                    sd = sqrt(trueSigma2)
                  )
                )
              }
            }
          } else {
            ## we can directly dose all patients
            thisDLTs <- rbinom(
              n = thisSize,
              size = 1L,
              prob = thisDLEProb
            )
            thisEff <- rnorm(
              n = thisSize,
              mean = thisMeanEff,
              sd = sqrt(trueSigma2)
            )

            if (thisData@placebo && (thisSize.PL > 0L)) {
              thisDLTs.PL <- rbinom(
                n = thisSize.PL,
                size = 1L,
                prob = thisProb.PL
              )
              thisEff.PL <- rnorm(
                n = thisSize.PL,
                mean = thisMeanEff.PL,
                sd = sqrt(trueSigma2)
              )
            }
          }

          ## update the data with this placebo (if any) cohort and then with active dose
          if (thisData@placebo && (thisSize.PL > 0L)) {
            thisData <- update(
              object = thisData,
              x = object@data@doseGrid[1],
              y = thisDLTs.PL,
              w = thisEff.PL,
              check = FALSE
            )

            ## update the data with active dose
            thisData <- update(
              object = thisData,
              x = thisDose,
              y = thisDLTs,
              w = thisEff,
              new_cohort = FALSE
            )
          } else {
            ## update the data with this cohort
            thisData <- update(
              object = thisData,
              x = thisDose,
              y = thisDLTs,
              w = thisEff
            )
          }
          ## Update model estimate in DLE and Eff models
          thisDLEModel <- update(
            object = object@model,
            data = thisData
          )

          thisEffModel <- update(
            object = object@eff_model,
            data = thisData
          )

          thisNu <- thisEffModel@nu


          thisSigma2 <- if (thisEffModel@use_fixed) {
            1 / thisNu
          } else {
            1 / (as.numeric(thisNu["a"] / thisNu["b"]))
          }


          ## what is the dose limit?
          doselimit <- maxDose(object@increments, data = thisData)



          ## => what is the next best dose?
          next_bd <- nextBest(object@nextBest,
            doselimit = doselimit,
            model = thisDLEModel,
            data = thisData,
            model_eff = thisEffModel,
            in_sim = TRUE
          )

          thisDose <- next_bd$next_dose
          thisTDtargetDuringTrial <- next_bd$dose_target_drt
          thisTDtargetDuringTrialAtDoseGrid <- next_bd$next_dose_drt
          thisTDtargetEndOfTrial <- next_bd$dose_target_eot
          thisTDtargetEndOfTrialAtDoseGrid <- next_bd$next_dose_eot
          thisGstar <- next_bd$dose_max_gain
          thisGstarAtDoseGrid <- next_bd$next_dose_max_gain

          Recommend <- min(thisTDtargetEndOfTrialAtDoseGrid, thisGstarAtDoseGrid)

          ## Find the 95 % CI and its ratio (upper to the lower of this 95% CI of each of the estimates)
          thisCITDEOT <- list(lower = next_bd$ci_dose_target_eot[1], upper = next_bd$ci_dose_target_eot[2])
          thisratioTDEOT <- next_bd$ci_ratio_dose_target_eot

          thisCIGstar <- list(lower = next_bd$ci_dose_max_gain[1], upper = next_bd$ci_dose_max_gain[2])
          thisratioGstar <- next_bd$ci_ratio_dose_max_gain

          ## Find the optimal dose
          OptimalDose <- min(thisGstar, thisTDtargetEndOfTrial)

          if (OptimalDose == thisGstar) {
            thisratio <- thisratioGstar
            thisCI <- thisCIGstar
          } else {
            thisratio <- thisratioTDEOT
            thisCI <- thisCITDEOT
          }

          ## evaluate stopping rules
          stopit <- stopTrial(object@stopping,
            dose = thisDose,
            model = thisDLEModel,
            data = thisData,
            Effmodel = thisEffModel
          )
          stopit_results <- h_unpack_stopit(stopit)
        }

        ## get the fits
        prob_fun <- probFunction(thisDLEModel, phi1 = thisDLEModel@phi1, phi2 = thisDLEModel@phi2)
        thisDLEFit <- list(
          phi1 = thisDLEModel@phi1,
          phi2 = thisDLEModel@phi2,
          probDLE = prob_fun(object@data@doseGrid)
        )

        eff_fun <- efficacyFunction(thisEffModel, theta1 = thisEffModel@theta1, theta2 = thisEffModel@theta2)
        thisEffFit <- list(
          theta1 = thisEffModel@theta1,
          theta2 = thisEffModel@theta2,
          ExpEff = eff_fun(object@data@doseGrid)
        )


        ## return the results
        thisResult <- list(
          data = thisData,
          dose = thisDose,
          TDtargetDuringTrial = thisTDtargetDuringTrial,
          TDtargetDuringTrialAtDoseGrid = thisTDtargetDuringTrialAtDoseGrid,
          TDtargetEndOfTrial = thisTDtargetEndOfTrial,
          TDtargetEndOfTrialAtDoseGrid = thisTDtargetEndOfTrialAtDoseGrid,
          Gstar = thisGstar,
          GstarAtDoseGrid = thisGstarAtDoseGrid,
          Recommend = Recommend,
          OptimalDose = OptimalDose,
          OptimalDoseAtDoseGrid = Recommend,
          ratio = thisratio,
          CI = thisCI,
          ratioGstar = thisratioGstar,
          CIGstar = thisCIGstar,
          ratioTDEOT = thisratioTDEOT,
          CITDEOT = thisCITDEOT,
          fitDLE = thisDLEFit,
          fitEff = thisEffFit,
          sigma2est = thisSigma2,
          stop = attr(
            stopit,
            "message"
          ),
          report_results = stopit_results
        )

        return(thisResult)
      }


      resultList <- get_result_list(
        fun = runSim,
        nsim = nsim,
        vars =
          c(
            "simSeeds",
            "args",
            "nArgs",
            "firstSeparate",
            "trueDLE",
            "trueEff",
            "trueNu",
            "object"
          ),
        parallel = parallel,
        n_cores = nCores
      )


      ## put everything in the Simulations format:

      ## setup the list for the simulated data objects
      dataList <- lapply(resultList, "[[", "data")

      ## the vector of the final dose recommendations
      recommendedDoses <- as.numeric(sapply(resultList, "[[", "Recommend"))


      ## set up list for the final TD during Trial Estimate
      TDtargetDuringTrialList <- as.numeric(sapply(resultList, "[[", "TDtargetDuringTrial"))

      ## set up list for the final TD End of Trial Estimate
      TDtargetEndOfTrialList <- as.numeric(sapply(resultList, "[[", "TDtargetEndOfTrial"))

      ## set up list for the final TD during Trial estimate at dose Grid
      TDtargetDuringTrialDoseGridList <- as.numeric(sapply(resultList, "[[", "TDtargetDuringTrialAtDoseGrid"))

      ## set up list for the final TD End Of Trial estimate at dose Grid
      TDtargetEndOfTrialDoseGridList <- as.numeric(sapply(resultList, "[[", "TDtargetEndOfTrialAtDoseGrid"))

      ## set up list for the final Gstar estimates
      GstarList <- as.numeric(sapply(resultList, "[[", "Gstar"))

      ## set up list for the final Gstar estimates at dose grid
      GstarAtDoseGridList <- as.numeric(sapply(resultList, "[[", "GstarAtDoseGrid"))

      ## set up list for final optimal dose estimates
      OptimalDoseList <- as.numeric(sapply(resultList, "[[", "OptimalDose"))

      ## set up list for final optimal dose estimates at dose Grid
      OptimalDoseAtDoseGridList <- as.numeric(sapply(resultList, "[[", "Recommend"))

      ## Set up the list for the final 95% CI obtained
      CIList <- lapply(resultList, "[[", "CI")

      ## Set up the list for the final ratios obtained
      ratioList <- as.numeric(sapply(resultList, "[[", "ratio"))

      ## Set up the list for the final 95% CI of the TDtarget End Of Trial obtained
      CITDEOTList <- lapply(resultList, "[[", "CITDEOT")

      ## Set up the list for the final ratios of the TDtarget End Of Trial obtained
      ratioTDEOTList <- as.numeric(sapply(resultList, "[[", "ratioTDEOT"))

      ## Set up the list for the final 95% CI of the Gstar obtained
      CIGstarList <- lapply(resultList, "[[", "CIGstar")

      ## Set up the list for the final ratios of the Gstar obtained
      ratioGstarList <- as.numeric(sapply(resultList, "[[", "ratioGstar"))



      ## set up the list for the final fits
      fitDLEList <- lapply(resultList, "[[", "fitDLE")
      fitEffList <- lapply(resultList, "[[", "fitEff")


      ## the vector of the sigma2
      sigma2Estimates <- as.numeric(sapply(resultList, "[[", "sigma2est"))

      ## the reasons for stopping
      stopReasons <- lapply(resultList, "[[", "stop")

      # individual stopping rule results as matrix, labels as column names
      stop_results <- lapply(resultList, "[[", "report_results")
      stop_report <- as.matrix(do.call(rbind, stop_results))


      ## return the results in the Simulations class object
      ret <- PseudoDualSimulations(
        data = dataList,
        doses = recommendedDoses,
        FinalTDtargetDuringTrialEstimates = TDtargetDuringTrialList,
        FinalTDtargetEndOfTrialEstimates = TDtargetEndOfTrialList,
        FinalTDtargetDuringTrialAtDoseGrid = TDtargetDuringTrialDoseGridList,
        FinalTDtargetEndOfTrialAtDoseGrid = TDtargetEndOfTrialDoseGridList,
        FinalCIs = CIList,
        FinalRatios = ratioList,
        FinalGstarEstimates = GstarList,
        FinalGstarAtDoseGrid = GstarAtDoseGridList,
        FinalGstarCIs = CIGstarList,
        FinalGstarRatios = ratioGstarList,
        FinalTDEOTCIs = CITDEOTList,
        FinalTDEOTRatios = ratioTDEOTList,
        FinalOptimalDose = OptimalDoseList,
        FinalOptimalDoseAtDoseGrid = OptimalDoseAtDoseGridList,
        fit = fitDLEList,
        fitEff = fitEffList,
        sigma2est = sigma2Estimates,
        stopReasons = stopReasons,
        stop_report = stop_report,
        seed = RNGstate
      )
      return(ret)
    }
)

## =========================================================================
## -----------------------------------------------------------------------------------------------
## Simulate design using DLE and efficacy responses with DLE and efficacy samples (pseudo models)
## --------------------------------------------------------------------------------------------
###
##' This is a methods to simulate dose escalation procedure using both DLE and efficacy responses.
##' This is a method based on the \code{\linkS4class{DualResponsesSamplesDesign}} where DLEmodel
##' used are of
##' \code{\linkS4class{ModelTox}} class object and efficacy model used are of
##' \code{\linkS4class{ModelEff}}
##' class object (special case is \code{\linkS4class{EffFlexi}} class model object).
##' In addition, DLE and efficacy samples are involved or generated in the simulation
##' process
##'
##' @param object the \code{\linkS4class{DualResponsesSamplesDesign}} object we want to
##' simulate the data from
##' @param nsim the number of simulations (default :1)
##' @param seed see \code{\link{set_seed}}
##' @param trueDLE a function which takes as input a dose (vector) and returns the true probability
##' (vector) of the occurrence of a DLE. Additional arguments can be supplied in \code{args}.
##' @param trueEff a function which takes as input a dose (vector) and returns the expected
##' efficacy responses (vector). Additional arguments can be supplied in \code{args}.
##' @param trueNu (not with code{\linkS4class{EffFlexi}}) the precision, the inverse of the
##' variance of the efficacy responses
##' @param trueSigma2 (only with code{\linkS4class{EffFlexi}}) the true variance of the efficacy
##' responses which must be a single positive scalar.
##' @param trueSigma2betaW (only with code{\linkS4class{EffFlexi}}) the true variance for the
##' random walk model used for smoothing. This must be a single positive scalar.
##' @param args data frame with arguments for the \code{trueDLE} and
##' \code{trueEff} function. The column names correspond to the argument
##' names, the rows to the values of the arguments. The rows are appropriately
##' recycled in the \code{nsim} simulations.
##' @param firstSeparate enroll the first patient separately from the rest of
##' the cohort? (not default) If yes, the cohort will be closed if a DLT occurs
##' in this patient.
##' @param mcmcOptions object of class \code{\linkS4class{McmcOptions}},
##' giving the MCMC options for each evaluation in the trial. By default,
##' the standard options are used
##' @param parallel should the simulation runs be parallelized across the
##' clusters of the computer? (not default)
##' @param nCores how many cores should be used for parallel computing?
##' Defaults to the number of cores on the machine, maximum 5.
##'
##' @param ... not used.
##'
##' @example examples/design-method-simulateDualResponsesSamplesDesign.R
##'
##' @return an object of class \code{\linkS4class{PseudoDualSimulations}} or
##' \code{\linkS4class{PseudoDualFlexiSimulations}}
##'
##' @export
##' @keywords methods
setMethod("simulate",
  signature =
    signature(
      object = "DualResponsesSamplesDesign",
      nsim = "ANY",
      seed = "ANY"
    ),
  def =
    function(object, nsim = 1L, seed = NULL,
             trueDLE, trueEff, trueNu = NULL,
             trueSigma2 = NULL, trueSigma2betaW = NULL,
             args = NULL, firstSeparate = FALSE,
             mcmcOptions = McmcOptions(),
             parallel = FALSE, nCores =
               min(parallel::detectCores(), 5L),
             ...) {
      ## common checks and extracts
      assert_function(trueDLE)
      assert_flag(firstSeparate)
      assert_count(nsim, positive = TRUE)
      assert_flag(parallel)
      assert_count(nCores, positive = TRUE)

      ## check if special case applies
      isFlexi <- is(object@eff_model, "EffFlexi")

      ## conditional code from here on:
      if (isFlexi) {
        ## special checks and extracts
        stopifnot(
          trueSigma2 > 0,
          trueSigma2betaW > 0,
          is.numeric(trueEff),
          length(trueEff) == length(object@data@doseGrid)
        )

        args <- as.data.frame(args)
        nArgs <- max(nrow(args), 1L)

        ## get names of arguments (excluding the first one which is the dose)
        trueDLEArgnames <- names(formals(trueDLE))[-1]

        ## seed handling
        RNGstate <- set_seed(seed)

        ## from this,
        ## generate the individual seeds for the simulation runs
        simSeeds <- sample(x = seq_len(1e5), size = as.integer(nsim))

        ## the function to produce the run a single simulation
        ## with index "iterSim"
        runSim <- function(iterSim) {
          ## set the seed for this run
          set.seed(simSeeds[iterSim])

          ## what is now the argument for the truth?
          ## (appropriately recycled)
          thisArgs <- args[(iterSim - 1) %% nArgs + 1, , drop = FALSE]

          ## so this truth is...
          thisTruthDLE <- function(dose) {
            do.call(
              trueDLE,
              ## First argument: the dose
              c(
                dose,
                ## Following arguments
                thisArgs
              )
            )
          }

          ## get the true Eff
          thisTruthEff <- trueEff

          ## start the simulated data with the provided one
          thisData <- object@data

          ## shall we stop the trial?
          ## First, we want to continue with the starting dose.
          ## This variable is updated after each cohort in the loop.
          stopit <- FALSE

          ## what is the next dose to be used?
          ## initialize with starting dose
          thisDose <- object@startingDose

          ## Start with specified sigma2 and sigma2betaW
          thisSigma2 <- trueSigma2
          thisSigma2betaW <- trueSigma2betaW


          ## inside this loop we simulate the whole trial, until stopping
          while (!stopit) {
            ## what is the probability for tox. at this dose?
            thisDLEProb <- thisTruthDLE(thisDose)
            thisDoseIndex <- which(thisDose == thisData@doseGrid)
            thisMeanEff <- thisTruthEff[thisDoseIndex]



            ## what is the cohort size at this dose?
            thisSize <- size(object@cohort_size,
              dose = thisDose,
              data = thisData
            )

            if (thisData@placebo) {
              thisSize.PL <- size(object@pl_cohort_size,
                dose = thisDose,
                data = thisData
              )
            }

            ## simulate DLTs: depends on whether we
            ## separate the first patient or not.
            if (firstSeparate && (thisSize > 1L)) {
              ## dose the first patient
              thisDLTs <- rbinom(
                n = 1L,
                size = 1L,
                prob = thisDLEProb
              )

              if (thisData@placebo && (thisSize.PL > 0L)) {
                thisDLTs.PL <- rbinom(
                  n = 1L,
                  size = 1L,
                  prob = thisProb.PL
                )
              }

              thisEff <- rnorm(
                n = 1L,
                mean = thisMeanEff,
                sd = sqrt(trueSigma2)
              )

              if (thisData@placebo && (thisSize.PL > 0L)) {
                thisEff.PL <- rnorm(
                  n = 1L,
                  mean = thisMeanEff.PL,
                  sd = sqrt(trueSigma2)
                )
              }

              ## if there is no DLT:
              if (thisDLTs == 0) {
                ## enroll the remaining patients
                thisDLTs <- c(
                  thisDLTs,
                  rbinom(
                    n = thisSize - 1L,
                    size = 1L,
                    prob = thisDLEProb
                  )
                )
                thisEff <- c(
                  thisEff,
                  rnorm(
                    n = thisSize - 1L,
                    mean = thisMeanEff,
                    sd = sqrt(trueSigma2)
                  )
                )
                if (thisData@placebo && (thisSize.PL > 0L)) {
                  thisDLTs.PL <- c(
                    thisDLTs.PL,
                    rbinom(
                      n = thisSize.PL,
                      size = 1L,
                      prob = thisProb.PL
                    )
                  )
                  thisEff.PL <- c(
                    thisMeanEff.PL,
                    rnorm(
                      n = thisSize.PL,
                      mean = thisMeanEff.PL,
                      sd = sqrt(trueSigma2)
                    )
                  )
                }
              }
            } else {
              ## we can directly dose all patients
              thisDLTs <- rbinom(
                n = thisSize,
                size = 1L,
                prob = thisDLEProb
              )

              thisEff <- rnorm(
                n = thisSize,
                mean = thisMeanEff,
                sd = sqrt(trueSigma2)
              )
              if (thisData@placebo && (thisSize.PL > 0L)) {
                thisDLTs.PL <- rbinom(
                  n = thisSize.PL,
                  size = 1L,
                  prob = thisProb.PL
                )
                thisEff.PL <- rnorm(
                  n = thisSize.PL,
                  mean = thisMeanEff.PL,
                  sd = sqrt(trueSigma2)
                )
              }
            }

            ## update the data with this placebo (if any) cohort and then with active dose
            if (thisData@placebo && (thisSize.PL > 0L)) {
              thisData <- update(
                object = thisData,
                x = object@data@doseGrid[1],
                y = thisDLTs.PL,
                w = thisEff.PL,
                check = FALSE
              )

              ## update the data with active dose
              thisData <- update(
                object = thisData,
                x = thisDose,
                y = thisDLTs,
                w = thisEff,
                new_cohort = FALSE
              )
            } else {
              ## update the data with this cohort
              thisData <- update(
                object = thisData,
                x = thisDose,
                y = thisDLTs,
                w = thisEff
              )
            }

            ## Update model estimate in DLE model
            thisDLEModel <- update(
              object = object@model,
              data = thisData
            )

            thisEffModel <- update(
              object = object@eff_model,
              data = thisData
            )


            ## what is the dose limit?
            doselimit <- maxDose(object@increments,
              data = thisData
            )

            ## generate DLE and Eff samples from the DLE and Eff model
            thisDLEsamples <- mcmc(
              data = thisData,
              model = thisDLEModel,
              options = mcmcOptions
            )

            thisEffsamples <- mcmc(
              data = thisData,
              model = thisEffModel,
              options = mcmcOptions
            )

            thisSigma2 <- mean(thisEffsamples@data$sigma2W)

            thisSigma2betaW <- mean(thisEffsamples@data$sigma2betaW)

            ## => what is the next best dose?

            next_bd <- nextBest(object@nextBest,
              doselimit = doselimit,
              samples = thisDLEsamples,
              model = thisDLEModel,
              model_eff = thisEffModel,
              samples_eff = thisEffsamples,
              data = thisData,
              in_sim = TRUE
            )

            thisDose <- next_bd$next_dose
            thisTDtargetDuringTrial <- next_bd$dose_target_drt
            thisTDtargetDuringTrialAtDoseGrid <- next_bd$next_dose_drt
            thisTDtargetEndOfTrial <- next_bd$dose_target_eot
            thisTDtargetEndOfTrialAtDoseGrid <- next_bd$next_dose_eot
            thisGstar <- next_bd$dose_max_gain
            thisGstarAtDoseGrid <- next_bd$next_dose_max_gain

            Recommend <- min(thisTDtargetEndOfTrialAtDoseGrid, thisGstarAtDoseGrid)

            ## Find the 95 % CI and its ratio (upper to the lower of this 95% CI of each of the estimates)
            thisCITDEOT <- list(lower = next_bd$ci_dose_target_eot[1], upper = next_bd$ci_dose_target_eot[2])
            thisratioTDEOT <- next_bd$ci_ratio_dose_target_eot

            thisCIGstar <- list(lower = next_bd$ci_dose_max_gain[1], upper = next_bd$ci_dose_max_gain[2])
            thisratioGstar <- next_bd$ci_ratio_dose_max_gain

            ## Find the optimal dose
            OptimalDose <- min(thisGstar, thisTDtargetEndOfTrial)

            if (OptimalDose == thisGstar) {
              thisratio <- thisratioGstar
              thisCI <- thisCIGstar
            } else {
              thisratio <- thisratioTDEOT
              thisCI <- thisCITDEOT
            }

            ## evaluate stopping rules
            stopit <- stopTrial(object@stopping,
              dose = thisDose,
              samples = thisDLEsamples,
              model = thisDLEModel,
              data = thisData,
              TDderive = object@nextBest@derive,
              Effmodel = thisEffModel,
              Effsamples = thisEffsamples,
              Gstarderive = object@nextBest@mg_derive
            )
            stopit_results <- h_unpack_stopit(stopit)
          }

          ## get the fits

          thisDLEFit <- fit(
            object = thisDLEsamples,
            model = thisDLEModel,
            data = thisData
          )

          thisEffFit <- fit(
            object = thisEffsamples,
            model = thisEffModel,
            data = thisData
          )


          ## return the results
          thisResult <-
            list(
              data = thisData,
              dose = thisDose,
              TDtargetDuringTrial = thisTDtargetDuringTrial,
              TDtargetDuringTrialAtDoseGrid = thisTDtargetDuringTrialAtDoseGrid,
              TDtargetEndOfTrial = thisTDtargetEndOfTrial,
              TDtargetEndOfTrialAtDoseGrid = thisTDtargetEndOfTrialAtDoseGrid,
              Gstar = thisGstar,
              GstarAtDoseGrid = thisGstarAtDoseGrid,
              Recommend = Recommend,
              OptimalDose = OptimalDose,
              OptimalDoseAtDoseGrid = Recommend,
              ratio = thisratio,
              CI = thisCI,
              ratioGstar = thisratioGstar,
              CIGstar = thisCIGstar,
              ratioTDEOT = thisratioTDEOT,
              CITDEOT = thisCITDEOT,
              fitDLE = subset(thisDLEFit,
                select =
                  c(middle, lower, upper)
              ),
              fitEff = subset(thisEffFit,
                select =
                  c(middle, lower, upper)
              ),
              sigma2est = thisSigma2,
              sigma2betaWest = thisSigma2betaW,
              stop =
                attr(
                  stopit,
                  "message"
                ),
              report_results = stopit_results
            )

          return(thisResult)
        }

        resultList <- get_result_list(
          fun = runSim,
          nsim = nsim,
          vars =
            c(
              "simSeeds",
              "args",
              "nArgs",
              "firstSeparate",
              "trueDLE",
              "trueEff",
              "trueSigma2",
              "trueSigma2betaW",
              "object",
              "mcmcOptions"
            ),
          parallel = parallel,
          n_cores = nCores
        )

        ## put everything in the Simulations format:

        ## setup the list for the simulated data objects
        dataList <- lapply(resultList, "[[", "data")

        ## the vector of the final dose recommendations
        recommendedDoses <- as.numeric(sapply(resultList, "[[", "Recommend"))


        ## set up the list for the final fits for both DLE and efficacy
        fitDLEList <- lapply(resultList, "[[", "fitDLE")
        fitEffList <- lapply(resultList, "[[", "fitEff")

        ## the vector of sigma2 estimates
        sigma2Estimates <- as.numeric(sapply(resultList, "[[", "sigma2est"))

        ## the vector of sigma2betaW estimates
        sigma2betaWEstimates <- as.numeric(sapply(resultList, "[[", "sigma2betaWest"))

        ## set up list for the final TD during Trial Estimate
        TDtargetDuringTrialList <- as.numeric(sapply(resultList, "[[", "TDtargetDuringTrial"))

        ## set up list for the final TD End of Trial Estimate
        TDtargetEndOfTrialList <- as.numeric(sapply(resultList, "[[", "TDtargetEndOfTrial"))

        ## set up list for the final TD during Trial estimate at dose Grid
        TDtargetDuringTrialDoseGridList <- as.numeric(sapply(resultList, "[[", "TDtargetDuringTrialAtDoseGrid"))

        ## set up list for the final TD End Of Trial estimate at dose Grid
        TDtargetEndOfTrialDoseGridList <- as.numeric(sapply(resultList, "[[", "TDtargetEndOfTrialAtDoseGrid"))

        ## set up list for the final Gstar estimates
        GstarList <- as.numeric(sapply(resultList, "[[", "Gstar"))

        ## set up list for the final Gstar estimates at dose grid
        GstarAtDoseGridList <- as.numeric(sapply(resultList, "[[", "GstarAtDoseGrid"))

        ## set up list for final optimal dose estimates
        OptimalDoseList <- as.numeric(sapply(resultList, "[[", "OptimalDose"))

        ## set up list for final optimal dose estimates at dose Grid
        OptimalDoseAtDoseGridList <- as.numeric(sapply(resultList, "[[", "Recommend"))

        ## Set up the list for the final 95% CI obtained
        CIList <- lapply(resultList, "[[", "CI")

        ## Set up the list for the final ratios obtained
        ratioList <- as.numeric(sapply(resultList, "[[", "ratio"))

        ## Set up the list for the final 95% CI of the TDtarget End Of Trial obtained
        CITDEOTList <- lapply(resultList, "[[", "CITDEOT")

        ## Set up the list for the final ratios of the TDtarget End Of Trial obtained
        ratioTDEOTList <- as.numeric(sapply(resultList, "[[", "ratioTDEOT"))

        ## Set up the list for the final 95% CI of the Gstar obtained
        CIGstarList <- lapply(resultList, "[[", "CIGstar")

        ## Set up the list for the final ratios of the Gstar obtained
        ratioGstarList <- as.numeric(sapply(resultList, "[[", "ratioGstar"))

        ## the reasons for stopping
        stopReasons <- lapply(resultList, "[[", "stop")

        # individual stopping rule results as matrix, labels as column names
        stop_results <- lapply(resultList, "[[", "report_results")
        stop_report <- as.matrix(do.call(rbind, stop_results))


        ## return the results in the Simulations class object
        ret <- PseudoDualFlexiSimulations(
          data = dataList,
          doses = recommendedDoses,
          FinalTDtargetDuringTrialEstimates = TDtargetDuringTrialList,
          FinalTDtargetEndOfTrialEstimates = TDtargetEndOfTrialList,
          FinalTDtargetDuringTrialAtDoseGrid = TDtargetDuringTrialDoseGridList,
          FinalTDtargetEndOfTrialAtDoseGrid = TDtargetEndOfTrialDoseGridList,
          FinalCIs = CIList,
          FinalRatios = ratioList,
          FinalGstarEstimates = GstarList,
          FinalGstarAtDoseGrid = GstarAtDoseGridList,
          FinalGstarCIs = CIGstarList,
          FinalGstarRatios = ratioGstarList,
          FinalTDEOTCIs = CITDEOTList,
          FinalTDEOTRatios = ratioTDEOTList,
          FinalOptimalDose = OptimalDoseList,
          FinalOptimalDoseAtDoseGrid = OptimalDoseAtDoseGridList,
          fit = fitDLEList,
          fitEff = fitEffList,
          sigma2est = sigma2Estimates,
          sigma2betaWest = sigma2betaWEstimates,
          stopReasons = stopReasons,
          stop_report = stop_report,
          seed = RNGstate
        )

        return(ret)
      } else {
        stopifnot(
          trueNu > 0,
          is.function(trueEff)
        )


        args <- as.data.frame(args)
        nArgs <- max(nrow(args), 1L)

        ## get names of arguments (excluding the first one which is the dose)
        trueDLEArgnames <- names(formals(trueDLE))[-1]
        trueEffArgnames <- names(formals(trueEff))[-1]



        ## seed handling
        RNGstate <- set_seed(seed)

        ## from this,
        ## generate the individual seeds for the simulation runs
        simSeeds <- sample(x = seq_len(1e5), size = nsim)

        ## the function to produce the run a single simulation
        ## with index "iterSim"
        runSim <- function(iterSim) {
          ## set the seed for this run
          set.seed(simSeeds[iterSim])

          ## what is now the argument for the truth?
          ## (appropriately recycled)
          thisArgs <- args[(iterSim - 1) %% nArgs + 1, , drop = FALSE]

          ## so this truth DLE function is...
          thisTruthDLE <- function(dose) {
            do.call(
              trueDLE,
              ## First argument: the dose
              c(
                dose,
                ## Following arguments: take only those that
                ## are required by the DLE function
                as.list(thisArgs)[trueDLEArgnames]
              )
            )
          }

          ## and the truth Eff function is:
          thisTruthEff <- function(dose) {
            do.call(
              trueEff,
              ## First argument: the dose
              c(
                dose,
                ## Following arguments: take only those that
                ## are required by the Eff function
                as.list(thisArgs)[trueEffArgnames]
              )
            )
          }

          ## find true sigma2 to generate responses

          trueSigma2 <- 1 / trueNu

          ## start the simulated data with the provided one
          thisData <- object@data


          ## shall we stop the trial?
          ## First, we want to continue with the starting dose.
          ## This variable is updated after each cohort in the loop.
          stopit <- FALSE

          ## what is the next dose to be used?
          ## initialize with starting dose
          thisDose <- object@startingDose

          ## inside this loop we simulate the whole trial, until stopping
          while (!stopit) {
            ## what is the probability for tox. at this dose?
            thisDLEProb <- thisTruthDLE(thisDose)
            thisMeanEff <- thisTruthEff(thisDose)

            ## what is the cohort size at this dose?
            thisSize <- size(object@cohort_size,
              dose = thisDose,
              data = thisData
            )

            ## simulate DLTs: depends on whether we
            ## separate the first patient or not.
            if (firstSeparate && (thisSize > 1L)) {
              ## dose the first patient
              thisDLTs <- rbinom(
                n = 1L,
                size = 1L,
                prob = thisDLEProb
              )

              if (thisData@placebo && (thisSize.PL > 0L)) {
                thisDLTs.PL <- rbinom(
                  n = 1L,
                  size = 1L,
                  prob = thisProb.PL
                )
              }

              thisEff <- rnorm(
                n = 1L,
                mean = thisMeanEff,
                sd = sqrt(trueSigma2)
              )

              if (thisData@placebo && (thisSize.PL > 0L)) {
                thisEff.PL <- rnorm(
                  n = 1L,
                  mean = thisMeanEff.PL,
                  sd = sqrt(trueSigma2)
                )
              }

              ## if there is no DLT:
              if (thisDLTs == 0) {
                ## enroll the remaining patients
                thisDLTs <- c(
                  thisDLTs,
                  rbinom(
                    n = thisSize - 1L,
                    size = 1L,
                    prob = thisDLEProb
                  )
                )
                thisEff <- c(
                  thisEff,
                  rnorm(
                    n = thisSize - 1L,
                    mean = thisMeanEff,
                    sd = sqrt(trueSigma2)
                  )
                )


                if (thisData@placebo && (thisSize.PL > 0L)) {
                  thisDLTs.PL <- c(
                    thisDLTs.PL,
                    rbinom(
                      n = thisSize.PL,
                      size = 1L,
                      prob = thisProb.PL
                    )
                  )
                  thisEff.PL <- c(
                    thisMeanEff.PL,
                    rnorm(
                      n = thisSize.PL,
                      mean = thisMeanEff.PL,
                      sd = sqrt(trueSigma2)
                    )
                  )
                }
              }
            } else {
              ## we can directly dose all patients
              thisDLTs <- rbinom(
                n = thisSize,
                size = 1L,
                prob = thisDLEProb
              )
              thisEff <- rnorm(
                n = thisSize,
                mean = thisMeanEff,
                sd = sqrt(trueSigma2)
              )

              if (thisData@placebo && (thisSize.PL > 0L)) {
                thisDLTs.PL <- rbinom(
                  n = thisSize.PL,
                  size = 1L,
                  prob = thisProb.PL
                )
                thisEff.PL <- rnorm(
                  n = thisSize.PL,
                  mean = thisMeanEff.PL,
                  sd = sqrt(trueSigma2)
                )
              }
            }



            ## update the data with this placebo (if any) cohort and then with active dose
            if (thisData@placebo && (thisSize.PL > 0L)) {
              thisData <- update(
                object = thisData,
                x = object@data@doseGrid[1],
                y = thisDLTs.PL,
                w = thisEff.PL,
                check = FALSE
              )

              ## update the data with active dose
              thisData <- update(
                object = thisData,
                x = thisDose,
                y = thisDLTs,
                w = thisEff,
                new_cohort = FALSE
              )
            } else {
              ## update the data with this cohort
              thisData <- update(
                object = thisData,
                x = thisDose,
                y = thisDLTs,
                w = thisEff
              )
            }


            ## Update model estimate in DLE and Eff models
            thisDLEModel <- update(
              object = object@model,
              data = thisData
            )

            thisEffModel <- update(
              object = object@eff_model,
              data = thisData
            )

            thisNu <- thisEffModel@nu

            thisDLEsamples <- mcmc(
              data = thisData,
              model = thisDLEModel,
              options = mcmcOptions
            )

            thisEffsamples <- mcmc(
              data = thisData,
              model = thisEffModel,
              options = mcmcOptions
            )

            thisSigma2 <- if (thisEffModel@use_fixed) {
              1 / thisNu
            } else {
              1 / (as.numeric(thisNu["a"] / thisNu["b"]))
            }

            ## what is the dose limit?
            doselimit <- maxDose(object@increments, data = thisData)



            ## => what is the next best dose?
            next_bd <- nextBest(object@nextBest,
              doselimit = doselimit,
              samples = thisDLEsamples,
              model = thisDLEModel,
              data = thisData,
              model_eff = thisEffModel,
              samples_eff = thisEffsamples,
              in_sim = TRUE
            )

            thisDose <- next_bd$next_dose
            thisTDtargetDuringTrial <- next_bd$dose_target_drt
            thisTDtargetDuringTrialAtDoseGrid <- next_bd$next_dose_drt
            thisTDtargetEndOfTrial <- next_bd$dose_target_eot
            thisTDtargetEndOfTrialAtDoseGrid <- next_bd$next_dose_eot
            thisGstar <- next_bd$dose_max_gain
            thisGstarAtDoseGrid <- next_bd$next_dose_max_gain

            Recommend <- min(thisTDtargetEndOfTrialAtDoseGrid, thisGstarAtDoseGrid)

            ## Find the 95 % CI and its ratio (upper to the lower of this 95% CI of each of the estimates)
            thisCITDEOT <- list(lower = next_bd$ci_dose_target_eot[1], upper = next_bd$ci_dose_target_eot[2])
            thisratioTDEOT <- next_bd$ci_ratio_dose_target_eot

            thisCIGstar <- list(lower = next_bd$ci_dose_max_gain[1], upper = next_bd$ci_dose_max_gain[2])
            thisratioGstar <- next_bd$ci_ratio_dose_max_gain

            ## Find the optimal dose
            OptimalDose <- min(thisGstar, thisTDtargetEndOfTrial)

            if (OptimalDose == thisGstar) {
              thisratio <- thisratioGstar
              thisCI <- thisCIGstar
            } else {
              thisratio <- thisratioTDEOT
              thisCI <- thisCITDEOT
            }


            ## evaluate stopping rules
            stopit <- stopTrial(object@stopping,
              dose = thisDose,
              samples = thisDLEsamples,
              model = thisDLEModel,
              data = thisData,
              TDderive = object@nextBest@derive,
              Effmodel = thisEffModel,
              Effsamples = thisEffsamples,
              Gstarderive = object@nextBest@mg_derive
            )
            stopit_results <- h_unpack_stopit(stopit)
          }
          ## get the fit
          thisDLEFit <- fit(
            object = thisDLEsamples,
            model = thisDLEModel,
            data = thisData
          )

          thisEffFit <- fit(
            object = thisEffsamples,
            model = thisEffModel,
            data = thisData
          )


          ## return the results
          thisResult <- list(
            data = thisData,
            dose = thisDose,
            TDtargetDuringTrial = thisTDtargetDuringTrial,
            TDtargetDuringTrialAtDoseGrid = thisTDtargetDuringTrialAtDoseGrid,
            TDtargetEndOfTrial = thisTDtargetEndOfTrial,
            TDtargetEndOfTrialAtDoseGrid = thisTDtargetEndOfTrialAtDoseGrid,
            Gstar = thisGstar,
            GstarAtDoseGrid = thisGstarAtDoseGrid,
            Recommend = Recommend,
            OptimalDose = OptimalDose,
            OptimalDoseAtDoseGrid = Recommend,
            ratio = thisratio,
            CI = thisCI,
            ratioGstar = thisratioGstar,
            CIGstar = thisCIGstar,
            ratioTDEOT = thisratioTDEOT,
            CITDEOT = thisCITDEOT,
            fitDLE = subset(thisDLEFit,
              select =
                c(middle, lower, upper)
            ),
            fitEff = subset(thisEffFit,
              select =
                c(middle, lower, upper)
            ),
            sigma2est = thisSigma2,
            stop = attr(
              stopit,
              "message"
            ),
            report_results = stopit_results
          )

          return(thisResult)
        }


        resultList <- get_result_list(
          fun = runSim,
          nsim = nsim,
          vars =
            c(
              "simSeeds",
              "args",
              "nArgs",
              "firstSeparate",
              "trueDLE",
              "trueEff",
              "trueNu",
              "object"
            ),
          parallel = parallel,
          n_cores = nCores
        )


        ## put everything in the Simulations format:

        ## setup the list for the simulated data objects
        dataList <- lapply(resultList, "[[", "data")

        ## the vector of the final dose recommendations
        recommendedDoses <- as.numeric(sapply(resultList, "[[", "Recommend"))

        ## set up list for the final TD during Trial Estimate
        TDtargetDuringTrialList <- as.numeric(sapply(resultList, "[[", "TDtargetDuringTrial"))

        ## set up list for the final TD End of Trial Estimate
        TDtargetEndOfTrialList <- as.numeric(sapply(resultList, "[[", "TDtargetEndOfTrial"))

        ## set up list for the final TD during Trial estimate at dose Grid
        TDtargetDuringTrialDoseGridList <- as.numeric(sapply(resultList, "[[", "TDtargetDuringTrialAtDoseGrid"))

        ## set up list for the final TD End Of Trial estimate at dose Grid
        TDtargetEndOfTrialDoseGridList <- as.numeric(sapply(resultList, "[[", "TDtargetEndOfTrialAtDoseGrid"))

        ## set up list for the final Gstar estimates
        GstarList <- as.numeric(sapply(resultList, "[[", "Gstar"))

        ## set up list for the final Gstar estimates at dose grid
        GstarAtDoseGridList <- as.numeric(sapply(resultList, "[[", "GstarAtDoseGrid"))

        ## set up list for final optimal dose estimates
        OptimalDoseList <- as.numeric(sapply(resultList, "[[", "OptimalDose"))

        ## set up list for final optimal dose estimates at dose Grid
        OptimalDoseAtDoseGridList <- as.numeric(sapply(resultList, "[[", "Recommend"))

        ## Set up the list for the final 95% CI obtained
        CIList <- lapply(resultList, "[[", "CI")

        ## Set up the list for the final ratios obtained
        ratioList <- as.numeric(sapply(resultList, "[[", "ratio"))

        ## Set up the list for the final 95% CI of the TDtarget End Of Trial obtained
        CITDEOTList <- lapply(resultList, "[[", "CITDEOT")

        ## Set up the list for the final ratios of the TDtarget End Of Trial obtained
        ratioTDEOTList <- as.numeric(sapply(resultList, "[[", "ratioTDEOT"))

        ## Set up the list for the final 95% CI of the Gstar obtained
        CIGstarList <- lapply(resultList, "[[", "CIGstar")

        ## Set up the list for the final ratios of the Gstar obtained
        ratioGstarList <- as.numeric(sapply(resultList, "[[", "ratioGstar"))

        ## set up the list for the final fits for both DLE and efficacy
        fitDLEList <- lapply(resultList, "[[", "fitDLE")
        fitEffList <- lapply(resultList, "[[", "fitEff")
        ## the vector of the sigma2
        sigma2Estimates <- as.numeric(sapply(resultList, "[[", "sigma2est"))

        ## the reasons for stopping
        stopReasons <- lapply(resultList, "[[", "stop")

        # individual stopping rule results as matrix, labels as column names
        stop_results <- lapply(resultList, "[[", "report_results")
        stop_report <- as.matrix(do.call(rbind, stop_results))


        ## return the results in the Simulations class object
        ret <- PseudoDualSimulations(
          data = dataList,
          doses = recommendedDoses,
          FinalTDtargetDuringTrialEstimates = TDtargetDuringTrialList,
          FinalTDtargetEndOfTrialEstimates = TDtargetEndOfTrialList,
          FinalTDtargetDuringTrialAtDoseGrid = TDtargetDuringTrialDoseGridList,
          FinalTDtargetEndOfTrialAtDoseGrid = TDtargetEndOfTrialDoseGridList,
          FinalCIs = CIList,
          FinalRatios = ratioList,
          FinalGstarEstimates = GstarList,
          FinalGstarAtDoseGrid = GstarAtDoseGridList,
          FinalGstarCIs = CIGstarList,
          FinalGstarRatios = ratioGstarList,
          FinalTDEOTCIs = CITDEOTList,
          FinalTDEOTRatios = ratioTDEOTList,
          FinalOptimalDose = OptimalDoseList,
          FinalOptimalDoseAtDoseGrid = OptimalDoseAtDoseGridList,
          fit = fitDLEList,
          fitEff = fitEffList,
          sigma2est = sigma2Estimates,
          stopReasons = stopReasons,
          stop_report = stop_report,
          seed = RNGstate
        )
        return(ret)
      }
    }
)

## --------------------------------------------------------------------------

##' Simulate outcomes from a time-to-DLT augmented CRM design (`DADesign`)
##'
##' @param object the \code{\linkS4class{DADesign}} object we want to simulate
##'   data from
##' @param nsim the number of simulations (default: 1)
##' @param seed see \code{\link{set_seed}}
##' @param truthTox a function which takes as input a dose (vector) and returns the
##'   true probability (vector) for toxicity and the time DLT occurs. Additional
##'   arguments can be supplied in \code{args}.
##' @param truthSurv a CDF which takes as input a time (vector) and returns
##'   the true cumulative probability (vector) that the DLT would occur conditioning on the patient
##'   has DLTs.
##' @param trueTmax (`number` or `NULL`)\cr the true maximum time at which DLTs can occur. Note that this must be larger thank `Tmax` from the `object`'s base data, which is the length of the DLT window, i.e. until which time DLTs are officially declared as such and used in the trial.
##' @param args data frame with arguments for the \code{truth} function. The
##'   column names correspond to the argument names, the rows to the values of the
##'   arguments. The rows are appropriately recycled in the \code{nsim}
##'   simulations. In order to produce outcomes from the posterior predictive
##'   distribution, e.g, pass an \code{object} that contains the data observed so
##'   far, \code{truth} contains the \code{prob} function from the model in
##'   \code{object}, and \code{args} contains posterior samples from the model.
##' @param firstSeparate enroll the first patient separately from the rest of
##'   the cohort? (not default) If yes, the cohort will be closed if a DLT occurs
##'   in this patient.
##' @param deescalate deescalation when a DLT occurs in cohorts with lower dose
##'   level.
##' @param mcmcOptions object of class \code{\linkS4class{McmcOptions}},
##'   giving the MCMC options for each evaluation in the trial. By default,
##'   the standard options are used.
##' @param DA document or rename this parameter to make it more meaningful
##' @param parallel should the simulation runs be parallelized across the
##'   clusters of the computer? (not default)
##' @param nCores how many cores should be used for parallel computing?
##' Defaults to the number of cores on the machine (maximum 5)
##' @param \dots not used
##' @param derive a named list of functions which derives statistics, based on the
##' vector of posterior MTD samples. Each list element must therefore accept
##' one and only one argument, which is a numeric vector, and return a number.
##'
##' @return an object of class \code{\linkS4class{Simulations}}
##'
##' @example examples/design-method-simulate-DADesign.R
##' @export
##' @keywords methods
setMethod("simulate",
  signature =
    signature(
      object = "DADesign",
      nsim = "ANY",
      seed = "ANY"
    ),
  def =
    function(object, nsim = 1L, seed = NULL,
             truthTox, truthSurv, trueTmax = NULL, args = NULL, firstSeparate = FALSE,
             deescalate = TRUE,
             mcmcOptions = McmcOptions(),
             DA = TRUE,
             parallel = FALSE, nCores = min(parallel::detectCores(), 5),
             derive = list(),
             ...) {
      ## checks and extracts
      assert_function(truthTox)
      assert_function(truthSurv)
      assert_flag(firstSeparate)
      assert_count(nsim, positive = TRUE)
      assert_flag(parallel)
      assert_count(nCores, positive = TRUE)

      args <- as.data.frame(args)
      nArgs <- max(nrow(args), 1L)

      ## seed handling
      RNGstate <- set_seed(seed)

      ## from this,
      ## generate the individual seeds for the simulation runs
      simSeeds <- sample(x = seq_len(1e5), size = as.integer(nsim))

      ## Define functions which are useful in DLT Surv generation
      inverse <- function(f, lower = -100, upper = 100) {
        function(y) {
          uniroot((function(x) f(x) - y),
            lower = lower, upper = upper
          )[1]$root
        }
      }

      ## The DLT window length
      thisData <- object@data
      Tmax <- thisData@Tmax

      if (is.null(trueTmax)) {
        trueTmax <- Tmax
      } else if (trueTmax < Tmax) {
        warning("trueTmax < Tmax! trueTmax is set to Tmax")
        trueTmax <- Tmax
      }

      ## Calculate the inverse function of Surv to DLT CDF
      itruthSurv <- inverse(truthSurv, 0, trueTmax)

      ## generate random variable of Surv to DLT data; return Tmax when no
      ## DLT
      rtruthSurv <- function(DLT, Tmax_, itruthSurv = itruthSurv) {
        u_i <- rep(-100, length(DLT)) # remember to check this

        if (sum(DLT == 0) > 0) {
          u_i[DLT == 0] <- Tmax_
        }

        if (sum(DLT == 1) > 0) {
          u_i[DLT == 1] <- unlist(lapply(runif(sum(DLT == 1), 0, 1), itruthSurv))
        }

        # make sure that results are always positive, otherwise we get
        # problems below.
        u_i[u_i == 0] <- 0.5
        return(u_i)
      }

      # A function to return follow up fulfull yes (TRUE) vs no (FALSE);
      ready_to_open <- function(day, window, thisSurv) {
        size <- length(thisSurv)
        # the date the patient starts;
        start_time <- apply(rbind(thisSurv[-size], window$patientGap[-1]), 2, min)
        # the relative time for each patient on the specified "date";
        individule_check <- day - cumsum(c(0, start_time))
        # the minial number should be 0;
        individule_check[individule_check < 0] <- 0
        follow_up <- apply(rbind(thisSurv, individule_check), 2, min)
        return(all((follow_up - apply(rbind(window$patientFollow, thisSurv), 2, min)) >= 0) & (max(follow_up) >= min(window$patientFollowMin, max(thisSurv))))
      }

      ## assume we have surfficient patients, i.e. patient can be immediately enrolled
      ## once the trial accumulation is open. This function will tell you when to open
      ## the next cohort;
      # this function applys to all trials;
      nextOpen <- function(window, thisSurv) {
        size <- length(thisSurv)

        window$patientGap <- window$patientGap[1:size] ## if length(window$pt)>length(thisSurv), assume the first length(thisSurv) patients were enrolled;
        ## if the DLT happens before the end of DLT window, then the next
        ## cohort/enrollment of the next patient would happened earlier;
        start_time <- apply(rbind(thisSurv[-size], window$patientGap[-1]), 2, min)
        # duration of the cohort (all DLT windows finished);
        maxT <- max(thisSurv + cumsum(c(0, start_time)))

        meetrequire <- sapply(1:maxT, function(i) {
          ready_to_open(i, window, thisSurv)
        })
        if (sum(meetrequire) > 0) {
          # the earliest time that the require is met;
          time <- min(c(1:maxT)[meetrequire])
        } else {
          time <- maxT
        }

        return(time)
      }

      ## the function to produce the run a single simulation
      ## with index "iterSim"
      runSim <- function(iterSim) {
        ## set the seed for this run
        set.seed(simSeeds[iterSim])

        # check<<-simSeeds[iterSim]
        ## what is now the argument for the truth?
        ## (appropriately recycled)
        thisArgs <- args[(iterSim - 1) %% nArgs + 1, , drop = FALSE]

        ## so this truth is...
        thisTruth <- function(dose) {
          do.call(
            truthTox,
            ## First argument: the dose
            c(
              dose,
              ## Following arguments
              thisArgs
            )
          )
        }

        ## start the simulated data with the provided one
        thisData <- object@data

        # In case there are placebo
        if (thisData@placebo) {
          ## what is the probability for tox. at placebo?
          thisProb.PL <- thisTruth(object@data@doseGrid[1])
        }

        ## shall we stop the trial?
        ## First, we want to continue with the starting dose.
        ## This variable is updated after each cohort in the loop.
        stopit <- FALSE

        ## the time clock for the study, set to 0 when the first simulated
        ## patient initially dosed;
        trialtime <- 0

        # initiate the true DLT, true DLT Surv and the C1/D1 for each patients
        factDLTs <- thisData@y
        factSurv <- thisData@u
        factT0 <- thisData@t0

        ## what is the next dose to be used?
        ## initialize with starting dose
        thisDose <- object@startingDose

        ## inside this loop we simulate the whole trial, until stopping
        while (!stopit) {
          ## what is the probability for tox. at this dose?
          thisProb <- thisTruth(thisDose)

          ## what is the cohort size at this dose?
          thisSize <- size(object@cohort_size,
            dose = thisDose,
            data = thisData
          )

          thisSafetywindow <- windowLength(object@safetyWindow, thisSize)
          # better: add a checkpoint in safetywindow--dim(safetywindow$pt)==thisSize;

          ## In case there are placebo
          if (thisData@placebo) {
            thisSize.PL <- size(object@pl_cohort_size,
              dose = thisDose,
              data = thisData
            )
          }


          ## simulate DLTs: depends on whether we
          ## separate the first patient or not.
          ## amended on May 24: if any patient had DLT before the
          ## first patient finished a staggered window
          ## further enrollment will be stopped;

          if (firstSeparate && (thisSize > 1L)) {
            ## dose the first patient
            thisDLTs <- rbinom(
              n = 1L,
              size = 1L,
              prob = thisProb
            )

            if (thisData@placebo) {
              thisDLTs.PL <- rbinom(
                n = 1L,
                size = 1L,
                prob = thisProb.PL
              )
            }

            thisSurv <- ceiling(rtruthSurv(DLT = thisDLTs, Tmax_ = trueTmax, itruthSurv = itruthSurv))

            if (Tmax < trueTmax) {
              thisDLTs[thisDLTs == 1 & thisSurv > Tmax] <- 0

              thisSurv <- apply(rbind(thisSurv, rep(Tmax, length(thisSurv))), 2, min)
            }

            thisT0 <- trialtime

            ## if there is no DLT during Safety window:
            ## and no DLTs of previous patients-->


            # need to update the DataDA object
            tempData <- update(
              object = thisData,
              y = c(factDLTs, thisDLTs), #### the y will be updated according to u
              u = c(factSurv, thisSurv),
              t0 = c(factT0, thisT0),
              x = thisDose,
              trialtime = trialtime + thisSafetywindow$patientGap[2]
            ) #### the u will be updated over time

            temptime <- (tempData@u + tempData@t0)[tempData@y == 1 & tempData@x <= thisDose]


            # identify number of DLTs occurs during the thisSafetywindow$pt[2]
            # if(thisSurv>thisSafetywindow$pt[2])
            if (sum(temptime > trialtime) == 0) {
              ## enroll the remaining patients
              thisDLTs <- c(
                thisDLTs,
                rbinom(
                  n = thisSize - 1L,
                  size = 1L,
                  prob = thisProb
                )
              )

              thisSurv <- c(
                thisSurv,
                ceiling(rtruthSurv(thisDLTs[-1], trueTmax, itruthSurv = itruthSurv))
              )

              if (Tmax < trueTmax) {
                thisDLTs[thisDLTs == 1 & thisSurv > Tmax] <- 0

                thisSurv <- apply(rbind(thisSurv, rep(Tmax, length(thisSurv))), 2, min)
              }

              # in case any DLT happens before the end of the safety window;
              real_window <- apply(rbind(thisSurv[-thisSize], thisSafetywindow$patientGap[-1]), 2, min)


              thisT0 <- trialtime + c(0, cumsum(real_window))

              if (thisData@placebo && (thisSize.PL > 1L)) {
                thisDLTs.PL <- c(
                  thisDLTs.PL,
                  rbinom(
                    n = thisSize.PL - 1L,
                    size = 1L,
                    prob = thisProb.PL
                  )
                )
              }
            }

            rm(tempData)
            rm(temptime)
          } else {
            ## we can directly dose all patients
            thisDLTs <- rbinom(
              n = thisSize,
              size = 1L,
              prob = thisProb
            )

            thisSurv <- ceiling(rtruthSurv(thisDLTs, trueTmax, itruthSurv = itruthSurv))
            ## should return a vector with a same dimention as thisDLTs
            if (Tmax < trueTmax) {
              thisDLTs[thisDLTs == 1 & thisSurv > Tmax] <- 0

              thisSurv <- apply(rbind(thisSurv, rep(Tmax, length(thisSurv))), 2, min)
            }
            # in case any DLT happens before the end of the safety window;
            real_window <- apply(rbind(thisSurv[-thisSize], thisSafetywindow$patientGap[-1]), 2, min)

            thisT0 <- trialtime + c(0, cumsum(real_window))
            ## should return a vector with a same dimention as thisDLTs

            if (thisData@placebo) {
              thisDLTs.PL <- rbinom(
                n = thisSize.PL,
                size = 1L,
                prob = thisProb.PL
              )
            }
          }


          ## update the data with this placebo (if any)
          ## cohort and then with active dose
          if (thisData@placebo) {
            thisData <- update(
              object = thisData,
              x = object@data@doseGrid[1],
              y = thisDLTs.PL
            )

            ## update the data with active dose
            thisData <- update(
              object = thisData,
              x = thisDose,
              y = thisDLTs,
              new_cohort = FALSE
            )

            ## JZ: additional part for DADesign--when to start the next cohort
            trialtime <- trialtime + nextOpen(
              window = thisSafetywindow,
              thisSurv = thisSurv
            )
          } else {
            ## JZ: since the whole y and u column need update.
            ## factDLTs and factSuev get update and then calculate the y and u value in
            ## thisData object
            #
            #                                                   ## update the data with this cohort
            #                                                   thisData <- update(object=thisData,
            #                                                                      x=thisDose,  ####the x will be constantly updated according to u
            #                                                                      y=thisDLTs,
            #                                                                      u=thisSurv)  ####the u will be constantly updated

            factDLTs <- c(factDLTs, thisDLTs)

            factSurv <- c(factSurv, thisSurv) # better: check the data type of factSurv and thisSurv;

            factT0 <- c(factT0, thisT0)


            tempnext <- nextOpen(
              window = thisSafetywindow,
              thisSurv = thisSurv
            )

            ##### if there are DLTs, patients in the higher cohorts will be dosed a lower dose or discontinue.
            if (deescalate == TRUE) {
              newDLTid <- ((factSurv + factT0) > trialtime & (factSurv + factT0 - trialtime) <= tempnext & factDLTs == 1)

              newDLTnum <- c(1:length(factDLTs))[newDLTid]

              newDLTnum <- newDLTnum[newDLTnum <= (length(factDLTs) - length(thisDLTs))]

              # if(ifelse(sum(newDLTnum)==0,Inf,min(newDLTnum))<=(length(factDLTs)-length(thisDLTs))){
              if (length(newDLTnum) > 0) {
                for (DLT_loop in newDLTnum) {
                  newDLTtime <- (factSurv + factT0)[DLT_loop]

                  # identify higher dose--impacted patients:
                  deescalateID <- c(DLT_loop:length(factDLTs))[c(thisData@x, rep(thisDose, length(thisDLTs)))[DLT_loop:length(factDLTs)] > thisData@x[DLT_loop]]


                  ## DLT will be observed once the followup time >= the time to DLT
                  factDLTs[deescalateID] <- as.integer(factDLTs * (newDLTtime >= factT0 + factSurv))[deescalateID]

                  ## update DLT free survival time
                  factSurv[deescalateID] <- apply(rbind(factSurv, newDLTtime - factT0), 2, min)[deescalateID]
                }

                tempnext <- min(tempnext, max((factSurv + factT0)[(length(factDLTs) - length(thisDLTs) + 1):length(factDLTs)]) - trialtime)
              }
            }






            ## JZ: future work: additional part for DADesign--when to start the next cohort
            ## nextOpen can be modified to incorporate different patient enrollment rate;
            ## currently assume we have sufficient patients;
            ## If there is a gap between cohorts for cohort manager meeting, it can be
            ## added to here;

            trialtime <- trialtime + tempnext



            ## Update thisData
            ## according to what can be observed by the time when the next cohort open;


            thisData <- update(
              object = thisData,
              y = factDLTs, #### the y will be updated according to u
              u = factSurv,
              t0 = factT0,
              x = thisDose,
              trialtime = trialtime
            ) #### the u will be updated over time

            try(if (length(thisData@x) != length(thisData@u) || length(thisData@u) != length(thisData@y)) {
              stop("x,y,u dimention error")
            })
          }


          # testthisdata<<-thisData

          ## what is the dose limit? #JZ should
          ## still work for the DataDA object
          doselimit <- maxDose(object@increments,
            data = thisData
          )



          ## generate samples from the model
          if (DA == TRUE) {
            thisSamples <- mcmc(
              data = thisData,
              model = object@model,
              options = mcmcOptions
            )
          } else if (DA == FALSE) {
            temp_model <- LogisticLogNormal(
              mean = object@model@params@mean,
              cov = object@model@params@cov,
              ref_dose = object@model@refDose
            )

            trunk_Data <- Data(
              x = thisData@x, y = thisData@y,
              doseGrid = thisData@doseGrid,
              cohort = thisData@cohort,
              ID = thisData@ID
            )

            thisSamples <- mcmc(
              data = trunk_Data,
              model = temp_model,
              options = mcmcOptions
            )
          }

          ## => what is the next best dose?
          thisDose <- nextBest(object@nextBest,
            doselimit = doselimit,
            samples = thisSamples,
            model = object@model,
            data = thisData
          )$value

          ## evaluate stopping rules
          stopit <- stopTrial(object@stopping,
            dose = thisDose,
            samples = thisSamples,
            model = object@model,
            data = thisData
          )
          stopit_results <- h_unpack_stopit(stopit)
        }

        ## get the fit
        thisFit <- fit(
          object = thisSamples,
          model = object@model,
          data = thisData
        )

        # Get the MTD estimate from the samples.

        target_dose_samples <- dose(
          mean(object@nextBest@target),
          model = object@model,
          samples = thisSamples
        )

        # Create a function for additional statistical summary.
        additional_stats <- lapply(derive, function(f) f(target_dose_samples))

        ## return the results
        thisResult <-
          list(
            data = thisData,
            dose = thisDose,
            duration = trialtime,
            fit =
              subset(thisFit,
                select = c(middle, lower, upper)
              ),
            stop =
              attr(
                stopit,
                "message"
              ),
            report_results = stopit_results,
            additional_stats = additional_stats
          )
        return(thisResult)
      }

      resultList <- get_result_list(
        fun = runSim, ## remove
        nsim = nsim,
        vars =
          c(
            "simSeeds",
            "args",
            "nArgs",
            "firstSeparate",
            "truthTox",
            "truthSurv",
            "object",
            "mcmcOptions",
            "nextOpen",
            "ready_to_open"
          ),
        parallel = parallel,
        n_cores = nCores
      )

      ## put everything in the Simulations format:

      ## setup the list for the simulated data objects
      dataList <- lapply(resultList, "[[", "data")


      ## the vector of the final dose recommendations
      recommendedDoses <- as.numeric(sapply(resultList, "[[", "dose"))

      ## the vector of the final trial duration;
      trialduration <- as.numeric(sapply(resultList, "[[", "duration"))

      ## setup the list for the final fits
      fitList <- lapply(resultList, "[[", "fit")

      ## the reasons for stopping
      stopReasons <- lapply(resultList, "[[", "stop")

      # individual stopping rule results as matrix, labels as column names
      stop_results <- lapply(resultList, "[[", "report_results")
      stop_report <- as.matrix(do.call(rbind, stop_results))

      additional_stats <- lapply(resultList, "[[", "additional_stats")

      ## return the results in the Simulations class object
      ret <- DASimulations(
        data = dataList,
        doses = recommendedDoses,
        fit = fitList,
        trialduration = trialduration,
        stop_report = stop_report,
        stop_reasons = stopReasons,
        additional_stats = additional_stats,
        seed = RNGstate
      )


      return(ret)
    }
)

## --------------------------------------------------------------------------
# nolint end

# simulate ----

## DesignGrouped ----

#' Simulate Method for the [`DesignGrouped`] Class
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' A simulate method for [`DesignGrouped`] designs.
#'
#' @param object (`DesignGrouped`)\cr the design we want to simulate trials from.
#' @param nsim (`number`)\cr how many trials should be simulated.
#' @param seed (`RNGstate`)\cr generated with [set_seed()].
#' @param truth (`function`)\cr a function which takes as input a dose (vector) and
#'   returns the true probability (vector) for toxicity for the mono arm.
#'   Additional arguments can be supplied in `args`.
#' @param combo_truth (`function`)\cr same as `truth` but for the combo arm.
#' @param args (`data.frame`)\cr optional `data.frame` with arguments that work
#'   for both the `truth` and `combo_truth` functions. The column names correspond to
#'   the argument names, the rows to the values of the arguments. The rows are
#'   appropriately recycled in the `nsim` simulations.
#' @param firstSeparate (`flag`)\cr whether to enroll the first patient separately
#'   from the rest of the cohort and close the cohort in case a DLT occurs in this
#'   first patient.
#' @param mcmcOptions (`McmcOptions`)\cr MCMC options for each evaluation in the trial.
#' @param parallel (`flag`)\cr whether the simulation runs are parallelized across the
#'   cores of the computer.
#' @param nCores (`number`)\cr how many cores should be used for parallel computing.
#' @param ... not used.
#'
#' @return A list of `mono` and `combo` simulation results as [`Simulations`] objects.
#'
#' @aliases simulate-DesignGrouped
#' @export
#' @example examples/Design-method-simulate-DesignGrouped.R
#'
setMethod(
  "simulate",
  signature =
    signature(
      object = "DesignGrouped",
      nsim = "ANY",
      seed = "ANY"
    ),
  def =
    function(object,
             nsim = 1L,
             seed = NULL,
             truth,
             combo_truth,
             args = data.frame(),
             firstSeparate = FALSE,
             mcmcOptions = McmcOptions(),
             parallel = FALSE,
             nCores = min(parallelly::availableCores(), 5),
             ...) {
      nsim <- as.integer(nsim)
      assert_function(truth)
      assert_function(combo_truth)
      assert_data_frame(args)
      assert_count(nsim, positive = TRUE)
      assert_flag(firstSeparate)
      assert_flag(parallel)
      assert_count(nCores, positive = TRUE)

      n_args <- max(nrow(args), 1L)
      rng_state <- set_seed(seed)
      sim_seeds <- sample.int(n = 2147483647, size = nsim)

      run_sim <- function(iter_sim) {
        set.seed(sim_seeds[iter_sim])
        current <- list(mono = list(), combo = list())
        # Define true toxicity functions.
        current$args <- args[(iter_sim - 1) %% n_args + 1, , drop = FALSE]
        current$mono$truth <- function(dose) do.call(truth, c(dose, current$args))
        current$combo$truth <- function(dose) do.call(combo_truth, c(dose, current$args))
        # Start the simulated data with the provided one.
        current$mono$data <- object@mono@data
        current$combo$data <- object@combo@data
        # We are in the first cohort and continue for mono and combo.
        current$first <- TRUE
        current$mono$stop <- current$combo$stop <- FALSE



        # What are the next doses to be used? Initialize with starting doses.
        if (object@same_dose_for_all || (!object@first_cohort_mono_only && object@same_dose_for_start)) {
          current$mono$dose <- current$combo$dose <- min(object@mono@startingDose, object@combo@startingDose)
        } else {
          current$mono$dose <- object@mono@startingDose
          current$combo$dose <- object@combo@startingDose
        }


        cohort_size_mono <- size(object@mono@cohort_size,
          dose = current$mono$dose,
          data = current$mono$data
        )

        cohort_size_combo <- size(object@combo@cohort_size,
          dose = current$combo$dose,
          data = current$combo$data
        )


        this_prob_mono <- current$mono$truth(current$mono$dose)
        this_prob_combo <- current$combo$truth(current$combo$dose)



        # Inside this loop we simulate the whole trial, until stopping.
        while (!(current$mono$stop && current$combo$stop)) {
          if (!current$mono$stop) {
            current$mono$data <- current$mono$data %>%
              h_determine_dlts(
                dose = current$mono$dose,
                prob = this_prob_mono,
                cohort_size = cohort_size_mono,
                first_separate = firstSeparate
              )
          }
          if (!current$combo$stop && (!current$first || !object@first_cohort_mono_only)) {
            current$combo$data <- current$combo$data %>%
              h_determine_dlts(
                dose = current$combo$dose,
                prob = this_prob_combo,
                cohort_size = cohort_size_combo,
                first_separate = firstSeparate
              )
          }


          current$grouped <- h_group_data(current$mono$data, current$combo$data)
          current$samples <- mcmc(current$grouped, object@model, mcmcOptions)
          if (!current$mono$stop) {
            current$mono$limit <- maxDose(object@mono@increments, data = current$mono$data)
            current$mono$dose <- object@mono@nextBest %>%
              nextBest(current$mono$limit, current$samples, object@model, current$grouped, group = "mono")
            current$mono$dose <- current$mono$dose$value
            current$mono$stop <- object@mono@stopping %>%
              stopTrial(current$mono$dose, current$samples, object@model, current$mono$data, group = "mono")
            current$mono$results <- h_unpack_stopit(current$mono$stop)
          }
          if (!current$combo$stop && (!current$first || !object@first_cohort_mono_only)) {
            current$combo$limit <- if (is.na(current$mono$dose)) {
              0
            } else {
              maxDose(object@combo@increments, current$combo$data) %>%
                min(current$mono$dose, na.rm = TRUE)
            }
            current$combo$dose <- object@combo@nextBest %>%
              nextBest(current$combo$limit, current$samples, object@model, current$grouped, group = "combo")
            current$combo$dose <- current$combo$dose$value
            current$combo$stop <- object@combo@stopping %>%
              stopTrial(current$combo$dose, current$samples, object@model, current$combo$data, group = "combo")
            current$combo$results <- h_unpack_stopit(current$combo$stop)
          }
          if (object@same_dose_for_all && !current$mono$stop && !current$combo$stop) {
            current$mono$dose <- current$combo$dose <- min(current$mono$dose, current$combo$dose)
          }
          if (object@stop_mono_with_combo) {
            if (current$combo$stop && !current$mono$stop) {
              current$mono$stop <- structure(
                TRUE,
                message = "mono stopped because combo stopped",
                report_label = "mono stopped because combo stopped"
              )
              new_result <- TRUE
            } else {
              new_result <- FALSE
            }
            current$mono$results <- c(
              current$mono$results,
              "mono stopped because combo stopped" = new_result
            )
          }
          if (current$first) {
            current$first <- FALSE
            if (object@first_cohort_mono_only && object@same_dose_for_start) {
              current$mono$dose <- current$combo$dose <- min(current$mono$dose, current$combo$dose)
            }
          }
        }
        current$mono$fit <- fit(current$samples, object@model, current$grouped, group = "mono")
        current$combo$fit <- fit(current$samples, object@model, current$grouped, group = "combo")
        lapply(
          X = current[c("mono", "combo")], FUN = with,
          list(
            data = data, dose = dose, fit = subset(fit, select = -dose),
            stop = attr(stop, "message"), results = results
          )
        )
      }
      vars_needed <- c("simSeeds", "args", "nArgs", "truth", "combo_truth", "firstSeparate", "object", "mcmcOptions")
      result_list <- get_result_list(run_sim, nsim, vars_needed, parallel, nCores)
      # Now we have a list with each element containing mono and combo. Reorder this a bit:
      result_list <- list(
        mono = lapply(result_list, "[[", "mono"),
        combo = lapply(result_list, "[[", "combo")
      )
      # Put everything in a list with both mono and combo Simulations:
      lapply(result_list, function(this_list) {
        data_list <- lapply(this_list, "[[", "data")
        recommended_doses <- as.numeric(sapply(this_list, "[[", "dose"))
        fit_list <- lapply(this_list, "[[", "fit")
        stop_reasons <- lapply(this_list, "[[", "stop")
        report_results <- lapply(this_list, "[[", "results")
        stop_report <- as.matrix(do.call(rbind, report_results))
        additional_stats <- lapply(this_list, "[[", "additional_stats")


        Simulations(
          data = data_list,
          doses = recommended_doses,
          fit = fit_list,
          stop_reasons = stop_reasons,
          stop_report = stop_report,
          additional_stats = additional_stats,
          seed = rng_state
        )
      })
    }
)

# tidy ----

## tidy-DualDesign ----

#' @rdname tidy
#' @aliases tidy-DualDesign
#' @example examples/Design-method-tidyDualDesign.R
#'
#' @export
setMethod(
  f = "tidy",
  signature = signature(x = "DualDesign"),
  definition = function(x, ...) {
    # Some Design objects have complex attributes whose structure is not supported.
    rv <- h_tidy_all_slots(x, attributes = FALSE) %>% h_tidy_class(x)
    if (length(rv) == 1) {
      rv[[names(rv)[1]]] %>% h_tidy_class(x)
    } else {
      rv
    }
  }
)

#' Internal Helper Functions for Validation of [`GeneralModel`] and [`ModelPseudo`] Objects
#'
#' @description `r lifecycle::badge("stable")`
#'
#' These functions are only used internally to validate the format of an input
#' [`GeneralModel`] and [`ModelPseudo`] or inherited classes and therefore are
#' not exported.
#'
#' @name v_model_objects
#' @param object (`GeneralModel`) or (`ModelPseudo`) \cr object to validate.
#' @return A `character` vector with the validation failure messages,
#'   or `TRUE` in case validation passes.
NULL

#' @describeIn v_model_objects validates that the names of the
#'   arguments in `init` function are included in `datanames` or `datanames_prior`
#'   slots.
v_general_model <- function(object) {
  v <- Validate()
  v$check(
    h_check_fun_formals(object@init, allowed = union(object@datanames, object@datanames_prior)),
    "Arguments of the init function must be data names"
  )
  v$result()
}

#' @describeIn v_model_objects validates that the logistic Kadane model
#'   parameters are valid.
v_model_logistic_kadane <- function(object) {
  v <- Validate()
  v$check(
    test_probability(object@theta, bounds_closed = FALSE),
    "theta must be a probability scalar > 0 and < 1"
  )
  is_xmin_number <- test_number(object@xmin)
  v$check(is_xmin_number, "xmin must be scalar")

  is_xmax_number <- test_number(object@xmax)
  v$check(is_xmax_number, "xmax must be scalar")

  if (is_xmin_number && is_xmax_number) {
    v$check(object@xmin < object@xmax, "xmin must be strictly smaller than xmax")
  }
  v$result()
}

#' @describeIn v_model_objects validates that the logistic Kadane model
#'   parameters with a beta and gamma prior are valid.
v_model_logistic_kadane_beta_gamma <- function(object) { # nolintr
  v <- Validate()
  v$check(
    test_number(object@alpha, lower = .Machine$double.xmin, finite = TRUE),
    "Beta distribution shape parameter alpha must be a positive scalar"
  )
  v$check(
    test_number(object@beta, lower = .Machine$double.xmin, finite = TRUE),
    "Beta distribution shape parameter beta must be a positive scalar"
  )
  v$check(
    test_number(object@shape, lower = .Machine$double.xmin, finite = TRUE),
    "Gamma distribution shape parameter must be a positive scalar"
  )
  v$check(
    test_number(object@rate, lower = .Machine$double.xmin, finite = TRUE),
    "Gamma distribution rate parameter must be a positive scalar"
  )
  v$result()
}

#' @describeIn v_model_objects validates that `weightpar` is valid.
v_model_logistic_normal_mix <- function(object) {
  v <- Validate()
  v$check(
    h_test_named_numeric(object@weightpar, permutation.of = c("a", "b")),
    "weightpar must be a named numerical vector of length two with positive finite values and names 'a', 'b'"
  )
  v$result()
}

#' @describeIn v_model_objects validates that `component` is a list with
#'   valid `ModelParamsNormal` objects as well as `weights` are correct.
v_model_logistic_normal_fixed_mix <- function(object) { # nolintr
  v <- Validate()
  v$check(
    all(sapply(object@components, test_class, "ModelParamsNormal")),
    "components must be a list with ModelParamsNormal S4 class objects"
  )
  comp_valid_result <- sapply(object@components, validObject, test = TRUE)
  comp_valid <- sapply(comp_valid_result, isTRUE)
  v$check(
    all(comp_valid),
    paste(
      "components must be a list with valid ModelParamsNormal S4 class objects",
      paste(unlist(comp_valid_result[!comp_valid]), collapse = ", "),
      collapse = ", ",
      sep = ", "
    )
  )
  v$check(
    length(object@components) == length(object@weights),
    "components must have same length as weights"
  )
  v$check(
    test_numeric(object@weights, lower = .Machine$double.xmin, finite = TRUE, any.missing = FALSE),
    "weights must be positive"
  )
  v$check(
    sum(object@weights) == 1,
    "weights must sum to 1"
  )
  v$check(
    test_flag(object@log_normal),
    "log_normal must be TRUE or FALSE"
  )
  v$result()
}

#' @describeIn v_model_objects validates that `share_weight` represents probability.
v_model_logistic_log_normal_mix <- function(object) { # nolintr
  v <- Validate()
  v$check(
    test_probability(object@share_weight),
    "share_weight does not specify a probability"
  )
  v$result()
}

#' @describeIn v_model_objects validates that [`DualEndpoint`] class slots are valid.
v_model_dual_endpoint <- function(object) {
  rmin <- .Machine$double.xmin
  v <- Validate()

  v$check(
    test_flag(object@use_log_dose),
    "use_log_dose must be TRUE or FALSE"
  )
  uf_sigma2W <- object@use_fixed["sigma2W"] # nolintr
  v$check(
    test_flag(uf_sigma2W),
    "use_fixed must be a named logical vector that contains name 'sigma2W'"
  )
  uf_rho <- object@use_fixed["rho"]
  v$check(
    test_flag(uf_rho),
    "use_fixed must be a named logical vector that contains name 'rho'"
  )

  if (isTRUE(uf_sigma2W)) {
    v$check(
      test_number(object@sigma2W, lower = rmin, finite = TRUE),
      "sigma2W must be a positive and finite numerical scalar"
    )
  } else {
    # object@sigma2W is a vector with parameters for InverseGamma(a, b).
    v$check(
      h_test_named_numeric(object@sigma2W, permutation.of = c("a", "b")),
      "sigma2W must be a named numerical vector of length two with positive finite values and names 'a', 'b'"
    )
  }

  if (isTRUE(uf_rho)) {
    v$check(
      test_number(object@rho, lower = -1 + rmin, upper = 1 - rmin), # rmin is ignored here!
      "rho must be a number in (-1, 1)"
    )
  } else {
    # object@rho is a vector with parameters for Beta(a, b).
    v$check(
      h_test_named_numeric(object@rho, permutation.of = c("a", "b")),
      "rho must be a named numerical vector of length two with positive finite values and names 'a', 'b'"
    )
  }

  v$result()
}

#' @describeIn v_model_objects validates that [`DualEndpointRW`] class slots are valid.
v_model_dual_endpoint_rw <- function(object) {
  v <- Validate()
  uf_sigma2W <- object@use_fixed["sigma2betaW"] # nolintr
  v$check(
    test_flag(uf_sigma2W),
    "use_fixed must be a named logical vector that contains name 'sigma2betaW'"
  )
  if (isTRUE(uf_sigma2W)) {
    v$check(
      test_number(object@sigma2betaW, lower = .Machine$double.xmin, finite = TRUE),
      "sigma2betaW must be a positive and finite numerical scalar"
    )
  } else {
    # object@sigma2betaW is a vector with parameters for InverseGamma(a, b).
    v$check(
      h_test_named_numeric(object@sigma2betaW, permutation.of = c("a", "b")),
      "sigma2betaW must be a named numerical vector of length two with positive finite values and names 'a', 'b'"
    )
  }
  v$result()
}

#' @describeIn v_model_objects validates that [`DualEndpointBeta`] class slots are valid.
v_model_dual_endpoint_beta <- function(object) {
  v <- Validate()

  for (s in c("E0", "Emax", "delta1", "mode")) {
    rmin <- .Machine$double.xmin
    uf <- object@use_fixed[s]

    v$check(
      test_flag(uf),
      paste0("use_fixed must be a named logical vector that contains name '", s, "'")
    )
    if (isTRUE(uf)) {
      if (s %in% c("delta1", "mode")) {
        v$check(
          test_number(slot(object, s), lower = rmin, finite = TRUE),
          paste(s, "must be a positive and finite numerical scalar")
        )
      }
    } else {
      # s is a vector with parameters for Uniform(s[1], s[2]) prior.
      v$check(
        test_numeric(
          slot(object, s),
          lower = 0,
          finite = TRUE,
          any.missing = FALSE,
          len = 2,
          unique = TRUE,
          sorted = TRUE
        ),
        paste(s, "must be a numerical vector of length two with non-negative, finite, unique and sorted (asc.) values")
      )
    }
  }

  v$result()
}

#' @describeIn v_model_objects validates that [`DualEndpointEmax`] class slots are valid.
v_model_dual_endpoint_emax <- function(object) {
  v <- Validate()

  for (s in c("E0", "Emax", "ED50")) {
    rmin <- .Machine$double.xmin
    uf <- object@use_fixed[s]

    v$check(
      test_flag(uf),
      paste0("use_fixed must be a named logical vector that contains name '", s, "'")
    )
    if (isTRUE(uf)) {
      v$check(
        test_number(slot(object, s), lower = rmin, finite = TRUE),
        paste(s, "must be a positive and finite numerical scalar")
      )
    } else {
      # s is a vector with parameters for Uniform(s[1], s[2]) prior.
      v$check(
        test_numeric(
          slot(object, s),
          lower = 0,
          finite = TRUE,
          any.missing = FALSE,
          len = 2,
          unique = TRUE,
          sorted = TRUE
        ),
        paste(s, "must be a numerical vector of length two with non-negative, finite, unique and sorted (asc.) values")
      )
    }
  }

  v$result()
}

#' @describeIn v_model_objects validates that [`LogisticIndepBeta`] class slots are valid.
v_model_logistic_indep_beta <- function(object) {
  v <- Validate()

  dle_len <- length(object@binDLE)
  v$check(
    test_numeric(object@binDLE, finite = TRUE, any.missing = FALSE, min.len = 2),
    "binDLE must be a finite numerical vector of minimum length 2, without missing values"
  )
  v$check(
    test_numeric(object@DLEdose, finite = TRUE, any.missing = FALSE, len = dle_len),
    "DLEdose must be a finite numerical vector of the same length as 'binDLE', without missing values"
  )
  v$check(
    test_integer(object@DLEweights, any.missing = FALSE, len = dle_len),
    "DLEweights must be an integer vector of the same length as 'binDLE', without missing values"
  )
  v$check(
    test_number(object@phi1),
    "phi1 must be a numerical scalar"
  )
  v$check(
    test_number(object@phi2),
    "phi2 must be a numerical scalar"
  )
  v$check(
    h_is_positive_definite(object@Pcov),
    "Pcov must be 2x2 positive-definite matrix without any missing values"
  )
  v$result()
}

#' @describeIn v_model_objects validates that [`Effloglog`] class slots are valid.
v_model_eff_log_log <- function(object) {
  rmin <- .Machine$double.xmin

  v <- Validate()
  v$check(
    test_numeric(object@eff, finite = TRUE, any.missing = FALSE, min.len = 2),
    "eff must be a finite numerical vector of minimum length 2, without missing values"
  )
  eff_dose_ok <- test_numeric(
    object@eff_dose,
    lower = rmin, finite = TRUE, any.missing = FALSE, len = length(object@eff)
  )
  v$check(
    eff_dose_ok,
    "eff_dose must be a finite numerical vector of the same length as 'eff', without missing values"
  )
  v$check(
    test_flag(object@use_fixed),
    "use_fixed must be a flag"
  )
  if (isTRUE(object@use_fixed)) {
    v$check(
      test_number(object@nu, lower = rmin, finite = TRUE),
      "nu must be a positive and finite numerical scalar"
    )
  } else {
    # object@nu is a vector with parameters for Gamma(a, b).
    v$check(
      h_test_named_numeric(object@nu, permutation.of = c("a", "b")),
      "nu must be a named numerical vector of length two with positive finite values and names 'a', 'b'"
    )
  }
  const_ok <- test_number(object@const, lower = 0)
  v$check(const_ok, "const must be a non-negative number")
  if (eff_dose_ok && const_ok) {
    v$check(
      min(object@data@doseGrid, object@eff_dose) > 1 - object@const,
      "For log-log model, doses and const must be such that dose + const > 1"
    )
  }
  v$check(
    test_number(object@theta1),
    "theta1 must be a numerical scalar"
  )
  v$check(
    test_number(object@theta2),
    "theta2 must be a numerical scalar"
  )
  nobs_no_dlt <- sum(!object@data@y)
  if (nobs_no_dlt + length(object@eff) > 2) {
    v$check(
      h_is_positive_definite(object@Pcov),
      "Pcov must be 2x2 positive-definite matrix without any missing values"
    )
  } else {
    v$check(
      test_matrix(object@Pcov, mode = "numeric", nrows = 2, ncols = 2) && all(is.na(object@Pcov)),
      "Pcov must be 2x2 numeric matrix with all values missing if the length of combined data is 2"
    )
  }
  v$check(
    test_numeric(object@mu, finite = TRUE, len = 2),
    "mu must be a finite numerical vector of length 2"
  )
  Xnrow <- ifelse(nobs_no_dlt > 0, nobs_no_dlt, length(object@eff_dose))
  v$check(
    test_matrix(object@X, mode = "numeric", nrows = Xnrow, ncols = 2, any.missing = FALSE),
    paste(
      "X must be a finite numerical matrix of size",
      Xnrow,
      "x 2, without any missing values"
    )
  )
  v$check(
    all(object@X[, 1] == 1),
    "X must be a design matrix, i.e. first column must be of 1s"
  )
  v$check(
    h_is_positive_definite(object@Q),
    "Q must be 2x2 positive-definite matrix without any missing values"
  )
  v$check(
    test_numeric(object@Y, finite = TRUE, any.missing = FALSE, len = Xnrow),
    paste(
      "Y must be a finite numerical vector of length",
      Xnrow,
      "and without any missing values"
    )
  )
  v$result()
}

#' @describeIn v_model_objects validates that [`EffFlexi`] class slots are valid.
v_model_eff_flexi <- function(object) {
  rmin <- .Machine$double.xmin

  v <- Validate()
  v$check(
    test_numeric(object@eff, finite = TRUE, any.missing = FALSE, min.len = 2),
    "eff must be a finite numerical vector of minimum length 2, without missing values"
  )
  v$check(
    test_numeric(
      object@eff_dose,
      lower = rmin, finite = TRUE, any.missing = FALSE, len = length(object@eff)
    ),
    "eff_dose must be a finite numerical vector of the same length as 'eff', without missing values"
  )

  uf_sigma2W <- object@use_fixed["sigma2W"] # nolintr
  v$check(
    test_flag(uf_sigma2W),
    "use_fixed must be a named logical vector that contains name 'sigma2W'"
  )
  uf_sigma2betaW <- object@use_fixed["sigma2betaW"] # nolintr
  v$check(
    test_flag(uf_sigma2betaW),
    "use_fixed must be a named logical vector that contains name 'sigma2betaW'"
  )

  if (isTRUE(uf_sigma2W)) {
    v$check(
      test_number(object@sigma2W, lower = rmin, finite = TRUE),
      "sigma2W must be a positive and finite numerical scalar"
    )
  } else {
    # object@sigma2W is a vector with parameters for InverseGamma(a, b).
    v$check(
      h_test_named_numeric(object@sigma2W, permutation.of = c("a", "b")),
      "sigma2W must be a named numerical vector of length two with positive finite values and names 'a', 'b'"
    )
  }
  if (isTRUE(uf_sigma2betaW)) {
    v$check(
      test_number(object@sigma2betaW, lower = rmin, finite = TRUE),
      "sigma2betaW must be a positive and finite numerical scalar"
    )
  } else {
    # object@sigma2betaW is a vector with parameters for InverseGamma(a, b).
    v$check(
      h_test_named_numeric(object@sigma2betaW, permutation.of = c("a", "b")),
      "sigma2betaW must be a named numerical vector of length two with positive finite values and names 'a', 'b'"
    )
  }

  v$check(
    test_flag(object@rw1),
    "rw1 must be a flag"
  )
  v$check(
    test_matrix(object@X, mode = "integer", ncols = object@data@nGrid, any.missing = FALSE),
    paste("X must be an integer matrix with", object@data@nGrid, "columns and without any missing values")
  )
  v$check(
    all(object@X == 0L | object@X == 1L),
    "X must be a matrix with 0-1 values only"
  )
  v$check(
    test_matrix(object@RW, nrows = object@data@nGrid, ncols = object@data@nGrid, any.missing = FALSE),
    paste0("RW must be ", object@data@nGrid, "x", object@data@nGrid, " matrix without any missing values")
  )
  v$check(
    test_int(object@RW_rank) && (object@RW_rank == (object@data@nGrid - ifelse(isTRUE(object@rw1), 1L, 2L))),
    "RW_rank must be an integer equal to data@nGrid - 2L"
  )
  v$result()
}

#' @describeIn v_model_objects validates that [`DALogisticLogNormal`] class slots are valid.
v_model_da_logistic_log_normal <- function(object) {
  v <- Validate()

  npiece_ok <- test_int(object@npiece)
  v$check(npiece_ok, "npiece must be a is a single integerish value")
  if (npiece_ok) {
    v$check(
      test_numeric(object@l, lower = 0, finite = TRUE, any.missing = FALSE, len = object@npiece),
      "prior parameter vector l of lambda must be a non-negative vector of length equal to npiece"
    )
  }
  v$check(
    test_number(object@c_par, finite = TRUE),
    "c_par must be a finite numerical scalar"
  )
  v$check(
    test_flag(object@cond_pem),
    "cond_pem must be a flag"
  )
  v$result()
}

#' @describeIn v_model_objects validates that [`TITELogisticLogNormal`] class slots are valid.
v_model_tite_logistic_log_normal <- function(object) { # nolintr
  v <- Validate()
  v$check(
    test_string(object@weight_method, pattern = "^linear$|^adaptive$"),
    "weight_method must be a string equal either to linear or adaptive"
  )
  v$result()
}

#' @describeIn v_model_objects validates that [`OneParLogNormalPrior`] class slots are valid.
v_model_one_par_exp_normal_prior <- function(object) { # nolintr
  v <- Validate()

  is_skel_prob_ok <- test_probabilities(object@skel_probs, unique = TRUE, sorted = TRUE)
  v$check(
    is_skel_prob_ok,
    "skel_probs must be a unique sorted probability values between 0 and 1"
  )

  if (is_skel_prob_ok) {
    # Validating skel_fun/skel_fun_inv on within the range of skeleton probs.
    skel_probs_range <- range(object@skel_probs)
    # Probabilities within the range of skel_probs.
    probs_in_range <- seq(from = skel_probs_range[1], to = skel_probs_range[2], by = 0.01)
    # Interpolated dose grid.
    doses_in_range <- object@skel_fun_inv(probs_in_range)
    v$check(
      isTRUE(all.equal(object@skel_fun(doses_in_range), probs_in_range)),
      "skel_fun_inv must be an inverse funtion of skel_fun function on within the range of sekeleton probs"
    )

    # Validating skel_fun/skel_fun_inv on outside the range of skeleton probs.
    probs_out_range <- c(
      seq(from = 0, to = skel_probs_range[1], length.out = 3),
      seq(from = skel_probs_range[2], to = 1, length.out = 3)
    )
    doses_out_range <- object@skel_fun_inv(probs_out_range)
    v$check(
      isTRUE(all.equal(object@skel_fun(doses_out_range), rep(skel_probs_range, each = 3))),
      "skel_fun_inv must be an inverse funtion of skel_fun function on outside the range of sekeleton probs"
    )
  }

  v$check(
    test_number(object@sigma2, lower = .Machine$double.xmin, finite = TRUE),
    "sigma2 must be a positive finite number"
  )

  v$result()
}

#' @describeIn v_model_objects validates that [`OneParExpPrior`] class slots are valid.
v_model_one_par_exp_prior <- function(object) {
  v <- Validate()

  is_skel_prob_ok <- test_probabilities(object@skel_probs, unique = TRUE, sorted = TRUE)
  v$check(
    is_skel_prob_ok,
    "skel_probs must be a unique sorted probability values between 0 and 1"
  )

  if (is_skel_prob_ok) {
    # Validating skel_fun/skel_fun_inv on within the range of skeleton probs.
    skel_probs_range <- range(object@skel_probs)
    # Probabilities within the range of skel_probs.
    probs_in_range <- seq(from = skel_probs_range[1], to = skel_probs_range[2], by = 0.01)
    # Interpolated dose grid.
    doses_in_range <- object@skel_fun_inv(probs_in_range)
    v$check(
      isTRUE(all.equal(object@skel_fun(doses_in_range), probs_in_range)),
      "skel_fun_inv must be an inverse funtion of skel_fun function on within the range of sekeleton probs"
    )

    # Validating skel_fun/skel_fun_inv on outside the range of skeleton probs.
    probs_out_range <- c(
      seq(from = 0, to = skel_probs_range[1], length.out = 3),
      seq(from = skel_probs_range[2], to = 1, length.out = 3)
    )
    doses_out_range <- object@skel_fun_inv(probs_out_range)
    v$check(
      isTRUE(all.equal(object@skel_fun(doses_out_range), rep(skel_probs_range, each = 3))),
      "skel_fun_inv must be an inverse funtion of skel_fun function on outside the range of sekeleton probs"
    )
  }

  v$check(
    test_number(object@lambda, lower = .Machine$double.xmin, finite = TRUE),
    "lambda must be a positive finite number"
  )

  v$result()
}

#' @describeIn v_model_objects confirms that cov is diagonal
v_logisticlognormalordinal <- function(object) {
  v <- Validate()
  # diag(x) returns a vector, not a matrix, so cannot use identical(x, diag(x)
  x <- object@params@cov
  diag(x) <- rep(0, ncol(x))
  v$check(
    all(x == 0),
    "covariance matrix must be diagonal"
  )
  v$result()
}

#' @include helpers.R
#' @include helpers_jags.R
#' @include Model-validity.R
#' @include ModelParams-class.R
#' @include CrmPackClass-class.R
NULL

# GeneralModel-class ----

#' `GeneralModel`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`GeneralModel`] is a general model class, from which all other specific
#' model-like classes inherit.
#'
#' @note The `datamodel` must obey the convention that the data input is
#'   called exactly in the same way as in the corresponding data class.
#'   All prior distributions for parameters should be contained in the
#'   model function `priormodel`. The background is that this can
#'   be used to simulate from the prior distribution, before obtaining any data.
#'
#' @slot datamodel (`function`)\cr a function representing the `JAGS` data model
#'   specification.
#' @slot priormodel (`function`)\cr a function representing the `JAGS` prior
#'   specification.
#' @slot modelspecs (`function`)\cr a function computing the list of the data
#'   model and prior model specifications that are required to be specified
#'   completely (e.g. prior parameters, reference dose, etc.), based on the data
#'   slots that are required as arguments of this function.
#'   Apart of data arguments, this function can be specified with one additional
#'   (optional) argument `from_prior` of type `logical` and length one. This
#'   `from_prior` flag can be used to differentiate the output of the `modelspecs`,
#'   as its value is taken directly from the `from_prior` argument of the `mcmc`
#'   method that invokes `modelspecs` function. That is, when `from_prior` is
#'   `TRUE`, then only `priormodel` JAGS model is used (`datamodel` is not used)
#'   by the `mcmc`, and hence `modelspecs` function should return all the parameters
#'   that are required by the `priormodel` only. If the value of `from_prior` is
#'   `FALSE`, then both JAGS models `datamodel` and `priormodel` are used in the
#'   MCMC sampler, and hence `modelspecs` function should return all the parameters
#'   required by both `datamodel` and `priormodel`.
#' @slot init (`function`)\cr a function computing the list of starting values
#'   for parameters required to be initialized in the MCMC sampler, based on the
#'   data slots that are required as arguments of this function.
#' @slot datanames (`character`)\cr the names of all data slots that are used
#'   by `datamodel` JAGS function. No other names should be specified here.
#' @slot datanames_prior (`character`)\cr the names of all data slots that are
#'   used by `priormodel` JAGS function. No other names should be specified here.
#' @slot sample (`character`)\cr names of all parameters from which you would
#'   like to save the MCMC samples.
#'
#' @seealso [`ModelPseudo`].
#'
#' @aliases GeneralModel
#' @export
#'
.GeneralModel <- setClass(
  Class = "GeneralModel",
  slots = c(
    datamodel = "function",
    priormodel = "function",
    modelspecs = "function",
    init = "function",
    datanames = "character",
    datanames_prior = "character",
    sample = "character"
  ),
  prototype = prototype(
    datamodel = I,
    priormodel = I,
    init = function() {
      list()
    }
  ),
  contains = "CrmPackClass",
  validity = v_general_model
)

## default constructor ----

#' @rdname GeneralModel-class
#' @note Typically, end users will not use the `.DefaultGeneralModel()` function.
#' @export
.DefaultGeneralModel <- function() {
  stop(paste0("Class GeneralModel should not be instantiated directly.  Please use one of its subclasses instead."))
}


# ModelLogNormal ----

## class ----

#' `ModelLogNormal`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`ModelLogNormal`] is the class for a model with a reference dose and bivariate
#' normal prior on the model parameters `alpha0` and natural logarithm of `alpha1`,
#' i.e.: \deqn{(alpha0, log(alpha1)) ~ Normal(mean, cov),}. Transformations other
#' than `log`, e.g. identity, can be specified too in `priormodel` slot.
#' The parameter `alpha1` has a log-normal distribution by default to ensure
#' positivity of `alpha1` which further guarantees `exp(alpha1) > 1`.
#' The slots of this class contain the mean vector, the covariance and
#' precision matrices of the bivariate normal distribution, as well as the
#' reference dose. Note that the precision matrix is an inverse of the
#' covariance matrix in the `JAGS`.
#' All ("normal") model specific classes inherit from this class.
#'
#' @slot params (`ModelParamsNormal`)\cr bivariate normal prior parameters.
#' @slot ref_dose (`positive_number`)\cr the reference dose.
#'
#' @seealso [`ModelParamsNormal`], [`LogisticNormal`], [`LogisticLogNormal`],
#'   [`LogisticLogNormalSub`], [`ProbitLogNormal`], [`ProbitLogNormalRel`].
#'
#' @aliases ModelLogNormal
#' @export
#'
.ModelLogNormal <- setClass(
  Class = "ModelLogNormal",
  contains = "GeneralModel",
  slots = c(
    params = "ModelParamsNormal",
    ref_dose = "positive_number"
  )
)

## constructor ----

#' @rdname ModelLogNormal-class
#'
#' @param mean (`numeric`)\cr the prior mean vector.
#' @param cov (`matrix`)\cr the prior covariance matrix. The precision matrix
#'   `prec` is internally calculated as an inverse of `cov`.
#' @param ref_dose (`number`)\cr the reference dose \eqn{x*} (strictly positive
#'   number).
#'
#' @export
#'
ModelLogNormal <- function(mean, cov, ref_dose = 1) {
  params <- ModelParamsNormal(mean, cov)
  .ModelLogNormal(
    params = params,
    ref_dose = positive_number(ref_dose),
    priormodel = function() {
      theta ~ dmnorm(mean, prec)
      alpha0 <- theta[1]
      alpha1 <- exp(theta[2])
    },
    modelspecs = function(from_prior) {
      ms <- list(mean = params@mean, prec = params@prec)
      if (!from_prior) {
        ms$ref_dose <- ref_dose
      }
      ms
    },
    init = function() {
      list(theta = c(0, 1))
    },
    datanames = c("nObs", "y", "x"),
    sample = c("alpha0", "alpha1")
  )
}

## default constructor ----

#' @rdname ModelLogNormal-class
#' @note Typically, end users will not use the `.DefaultModelLogNormal()` function.
#' @export
.DefaultModelLogNormal <- function() {
  ModelLogNormal(mean = c(-0.85, 1), cov = matrix(c(1, -0.5, -0.5, 1), nrow = 2))
}

# LogisticNormal ----

## class ----

#' `LogisticNormal`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`LogisticNormal`] is the class for the usual logistic regression model with
#' a bivariate normal prior on the intercept and slope.
#'
#' @details The covariate is the natural logarithm of the dose \eqn{x} divided by
#'   the reference dose \eqn{x*}, i.e.:
#'   \deqn{logit[p(x)] = alpha0 + alpha1 * log(x/x*),}
#'   where \eqn{p(x)} is the probability of observing a DLT for a given dose \eqn{x}.
#'   The prior \deqn{(alpha0, alpha1) ~ Normal(mean, cov).}
#'
#' @seealso [`ModelLogNormal`], [`LogisticLogNormal`], [`LogisticLogNormalSub`],
#'   [`ProbitLogNormal`], [`ProbitLogNormalRel`], [`LogisticNormalMixture`].
#'
#' @aliases LogisticNormal
#' @export
#'
.LogisticNormal <- setClass(
  Class = "LogisticNormal",
  contains = "ModelLogNormal"
)

## constructor ----

#' @rdname LogisticNormal-class
#'
#' @inheritParams ModelLogNormal
#'
#' @export
#' @example examples/Model-class-LogisticNormal.R
#'
LogisticNormal <- function(mean, cov, ref_dose = 1) {
  model_ln <- ModelLogNormal(mean = mean, cov = cov, ref_dose = ref_dose)

  .LogisticNormal(
    model_ln,
    datamodel = function() {
      for (i in 1:nObs) {
        logit(p[i]) <- alpha0 + alpha1 * log(x[i] / ref_dose)
        y[i] ~ dbern(p[i])
      }
    },
    priormodel = function() {
      theta ~ dmnorm(mean, prec)
      alpha0 <- theta[1]
      alpha1 <- theta[2]
    }
  )
}

## default constructor ----

#' @rdname LogisticNormal-class
#' @note Typically, end users will not use the `.DefaultLogisticNormal()` function.
#' @export
.DefaultLogisticNormal <- function() {
  LogisticNormal(mean = c(-0.85, 1), cov = matrix(c(1, -0.5, -0.5, 1), nrow = 2))
}


# LogisticLogNormal ----

## class ----

#' `LogisticLogNormal`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`LogisticLogNormal`] is the class for the usual logistic regression model
#' with a bivariate normal prior on the intercept and log slope.
#'
#' @details The covariate is the natural logarithm of the dose \eqn{x} divided by
#'   the reference dose \eqn{x*}, i.e.:
#'   \deqn{logit[p(x)] = alpha0 + alpha1 * log(x/x*),}
#'   where \eqn{p(x)} is the probability of observing a DLT for a given dose \eqn{x}.
#'   The prior \deqn{(alpha0, log(alpha1)) ~ Normal(mean, cov).}
#'
#' @seealso [`ModelLogNormal`], [`LogisticNormal`], [`LogisticLogNormalSub`],
#'   [`ProbitLogNormal`], [`ProbitLogNormalRel`], [`LogisticLogNormalMixture`],
#'   [`DALogisticLogNormal`].
#'
#' @aliases LogisticLogNormal
#' @export
#'
.LogisticLogNormal <- setClass(
  Class = "LogisticLogNormal",
  contains = "ModelLogNormal"
)

## constructor ----

#' @rdname LogisticLogNormal-class
#'
#' @inheritParams ModelLogNormal
#'
#' @export
#' @example examples/Model-class-LogisticLogNormal.R
#'
LogisticLogNormal <- function(mean, cov, ref_dose = 1) {
  model_ln <- ModelLogNormal(mean = mean, cov = cov, ref_dose = ref_dose)

  .LogisticLogNormal(
    model_ln,
    datamodel = function() {
      for (i in 1:nObs) {
        logit(p[i]) <- alpha0 + alpha1 * log(x[i] / ref_dose)
        y[i] ~ dbern(p[i])
      }
    }
  )
}

## default constructor ----

#' @rdname LogisticLogNormal-class
#' @note Typically, end users will not use the `.DefaultLogisticLogNormal()` function.
#' @export
.DefaultLogisticLogNormal <- function() {
  LogisticLogNormal(
    mean = c(-0.85, 1),
    cov = matrix(c(1, -0.5, -0.5, 1), nrow = 2),
    ref_dose = 50
  )
}

# LogisticLogNormalSub ----

## class ----

#' `LogisticLogNormalSub`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`LogisticLogNormalSub`] is the class for a standard logistic model with
#' bivariate (log) normal prior with subtractive dose standardization.
#'
#' @details The covariate is the dose \eqn{x} minus the reference dose \eqn{x*},
#'   i.e.:
#'   \deqn{logit[p(x)] = alpha0 + alpha1 * (x - x*),}
#'   where \eqn{p(x)} is the probability of observing a DLT for a given dose \eqn{x}.
#'   The prior \deqn{(alpha0, log(alpha1)) ~ Normal(mean, cov).}
#'
#' @slot params (`ModelParamsNormal`)\cr bivariate normal prior parameters.
#' @slot ref_dose (`number`)\cr the reference dose \eqn{x*}.
#'
#' @seealso [`LogisticNormal`], [`LogisticLogNormal`], [`ProbitLogNormal`],
#'   [`ProbitLogNormalRel`].
#'
#' @aliases LogisticLogNormalSub
#' @export
#'
.LogisticLogNormalSub <- setClass(
  Class = "LogisticLogNormalSub",
  slots = c(
    params = "ModelParamsNormal",
    ref_dose = "numeric"
  ),
  contains = "GeneralModel"
)

## constructor ----

#' @rdname LogisticLogNormalSub-class
#'
#' @param mean (`numeric`)\cr the prior mean vector.
#' @param cov (`matrix`)\cr the prior covariance matrix. The precision matrix
#'   `prec` is internally calculated as an inverse of `cov`.
#' @param ref_dose (`number`)\cr the reference dose \eqn{x*}.
#'
#' @export
#' @example examples/Model-class-LogisticLogNormalSub.R
#'
LogisticLogNormalSub <- function(mean, cov, ref_dose = 0) {
  params <- ModelParamsNormal(mean, cov)
  .LogisticLogNormalSub(
    params = params,
    ref_dose = ref_dose,
    datamodel = function() {
      for (i in 1:nObs) {
        logit(p[i]) <- alpha0 + alpha1 * (x[i] - ref_dose)
        y[i] ~ dbern(p[i])
      }
    },
    priormodel = function() {
      theta ~ dmnorm(mean, prec)
      alpha0 <- theta[1]
      alpha1 <- exp(theta[2])
    },
    modelspecs = function(from_prior) {
      ms <- list(mean = params@mean, prec = params@prec)
      if (!from_prior) {
        ms$ref_dose <- ref_dose
      }
      ms
    },
    init = function() {
      list(theta = c(0, -20))
    },
    datanames = c("nObs", "y", "x"),
    sample = c("alpha0", "alpha1")
  )
}


## default constructor ----

#' @rdname LogisticLogNormalSub-class
#' @note Typically, end-users will not use the `.DefaultLogisticLogNormalSub()` function.
#' @export
.DefaultLogisticLogNormalSub <- function() {
  LogisticLogNormalSub(
    mean = c(-0.85, 1),
    cov = matrix(c(1, -0.5, -0.5, 1), nrow = 2),
    ref_dose = 50
  )
}

# ProbitLogNormal ----

## class ----

#' `ProbitLogNormal`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`ProbitLogNormal`] is the class for probit regression model with a
#' bivariate normal prior on the intercept and log slope.
#'
#' @details The covariate is the natural logarithm of dose \eqn{x} divided by a
#'   reference dose \eqn{x*}, i.e.:
#'   \deqn{probit[p(x)] = alpha0 + alpha1 * log(x/x*),}
#'   where \eqn{p(x)} is the probability of observing a DLT for a given dose \eqn{x}.
#'   The prior \deqn{(alpha0, log(alpha1)) ~ Normal(mean, cov).}
#'
#' @note This model is also used in the [`DualEndpoint`] classes, so this class
#'   can be used to check the prior assumptions on the dose-toxicity model, even
#'   when sampling from the prior distribution of the dual endpoint model is not
#'   possible.
#'
#' @seealso [`ModelLogNormal`], [`LogisticNormal`], [`LogisticLogNormal`],
#'   [`LogisticLogNormalSub`], [`ProbitLogNormalRel`].
#'
#' @aliases ProbitLogNormalLogDose
#' @export
#'
.ProbitLogNormal <- setClass(
  Class = "ProbitLogNormal",
  contains = "ModelLogNormal"
)

## constructor ----

#' @rdname ProbitLogNormal-class
#'
#' @inheritParams ModelLogNormal
#'
#' @export
#' @example examples/Model-class-ProbitLogNormal.R
#'
ProbitLogNormal <- function(mean, cov, ref_dose = 1) {
  model_ln <- ModelLogNormal(mean = mean, cov = cov, ref_dose = ref_dose)

  .ProbitLogNormal(
    model_ln,
    datamodel = function() {
      for (i in 1:nObs) {
        probit(p[i]) <- alpha0 + alpha1 * log(x[i] / ref_dose)
        y[i] ~ dbern(p[i])
      }
    }
  )
}

## default constructor ----

#' @rdname ProbitLogNormal-class
#' @note Typically, end users will not use the `.DefaultProbitLogNormal()` function.
#' @export
.DefaultProbitLogNormal <- function() {
  ProbitLogNormal(
    mean = c(-0.85, 1),
    cov = matrix(c(1, -0.5, -0.5, 1), nrow = 2),
    ref_dose = 7.2
  )
}

# ProbitLogNormalRel ----

## class ----

#' `ProbitLogNormalRel`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`ProbitLogNormalRel`] is the class for probit regression model with a bivariate
#' normal prior on the intercept and log slope.
#'
#' @details The covariate is the dose \eqn{x} divided by a reference dose \eqn{x*},
#'   i.e.:
#'   \deqn{probit[p(x)] = alpha0 + alpha1 * x/x*,}
#'   where \eqn{p(x)} is the probability of observing a DLT for a given dose \eqn{x}.
#'   The prior \deqn{(alpha0, log(alpha1)) ~ Normal(mean, cov).}
#'
#' @note This model is also used in the [`DualEndpoint`] classes, so this class
#'   can be used to check the prior assumptions on the dose-toxicity model, even
#'   when sampling from the prior distribution of the dual endpoint model is not
#'   possible.
#'
#' @seealso [`ModelLogNormal`], [`LogisticNormal`], [`LogisticLogNormal`],
#'   [`LogisticLogNormalSub`], [`ProbitLogNormal`].
#'
#' @aliases ProbitLogNormalRel
#' @export
#'
.ProbitLogNormalRel <- setClass(
  Class = "ProbitLogNormalRel",
  contains = "ModelLogNormal"
)

## constructor ----

#' @rdname ProbitLogNormalRel-class
#'
#' @inheritParams ModelLogNormal
#'
#' @export
#' @example examples/Model-class-ProbitLogNormalRel.R
#'
ProbitLogNormalRel <- function(mean, cov, ref_dose = 1) {
  model_ln <- ModelLogNormal(mean = mean, cov = cov, ref_dose = ref_dose)

  .ProbitLogNormalRel(
    model_ln,
    datamodel = function() {
      for (i in 1:nObs) {
        probit(p[i]) <- alpha0 + alpha1 * (x[i] / ref_dose)
        y[i] ~ dbern(p[i])
      }
    }
  )
}

## default constructor ----

#' @rdname ProbitLogNormalRel-class
#' @note Typically, end users will not use the `.DefaultProbitLogNormalRel()` function.
#' @export
.DefaultProbitLogNormalRel <- function() {
  ProbitLogNormalRel(mean = c(-0.85, 1), cov = matrix(c(1, -0.5, -0.5, 1), nrow = 2))
}

# LogisticLogNormalGrouped ----

## class ----

#' `LogisticLogNormalGrouped`
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' [`LogisticLogNormalGrouped`] is the class for a logistic regression model
#'  for both the mono and the combo arms of the simultaneous dose escalation
#'  design.
#'
#' @details The continuous covariate is the natural logarithm of the dose \eqn{x} divided by
#'   the reference dose \eqn{x*} as in [`LogisticLogNormal`]. In addition,
#'   \eqn{I_c} is a binary indicator covariate which is 1 for the combo arm and 0 for the mono arm.
#'   The model is then defined as:
#'   \deqn{logit[p(x)] = (alpha0 + I_c * delta0) + (alpha1 + I_c * delta1) * log(x / x*),}
#'   where \eqn{p(x)} is the probability of observing a DLT for a given dose \eqn{x},
#'   and `delta0` and `delta1` are the differences in the combo arm compared to the mono intercept
#'   and slope parameters `alpha0` and `alpha1`.
#'   The prior is defined as \deqn{(alpha0, log(delta0), log(alpha1), log(delta1)) ~ Normal(mean, cov).}
#'
#' @seealso [`ModelLogNormal`], [`LogisticLogNormal`].
#'
#' @aliases LogisticLogNormalGrouped
#' @export
#'
.LogisticLogNormalGrouped <- setClass(
  Class = "LogisticLogNormalGrouped",
  contains = "ModelLogNormal"
)

## constructor ----

#' @rdname LogisticLogNormalGrouped-class
#'
#' @inheritParams ModelLogNormal
#'
#' @export
#' @example examples/Model-class-LogisticLogNormalGrouped.R
#'
LogisticLogNormalGrouped <- function(mean, cov, ref_dose = 1) {
  params <- ModelParamsNormal(mean, cov)
  .LogisticLogNormalGrouped(
    params = params,
    ref_dose = positive_number(ref_dose),
    priormodel = function() {
      theta ~ dmnorm(mean, prec)
      alpha0 <- theta[1]
      delta0 <- exp(theta[2])
      alpha1 <- exp(theta[3])
      delta1 <- exp(theta[4])
    },
    datamodel = function() {
      for (i in 1:nObs) {
        logit(p[i]) <- (alpha0 + is_combo[i] * delta0) +
          (alpha1 + is_combo[i] * delta1) * log(x[i] / ref_dose)
        y[i] ~ dbern(p[i])
      }
    },
    modelspecs = function(group, from_prior) {
      ms <- list(
        mean = params@mean,
        prec = params@prec
      )
      if (!from_prior) {
        ms$ref_dose <- ref_dose
        ms$is_combo <- as.integer(group == "combo")
      }
      ms
    },
    init = function() {
      list(theta = c(0, 1, 1, 1))
    },
    datanames = c("nObs", "y", "x"),
    sample = c("alpha0", "delta0", "alpha1", "delta1")
  )
}

## default constructor ----

#' @rdname LogisticLogNormalGrouped-class
#' @note Typically, end users will not use the `.DefaultLogisticLogNormalGrouped()` function.
#' @export
.DefaultLogisticLogNormalGrouped <- function() {
  LogisticLogNormalGrouped(
    mean = rep(0, 4),
    cov = diag(rep(1, 4)),
  )
}

# LogisticKadane ----

## class ----

#' `LogisticKadane`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`LogisticKadane`] is the class for the logistic model in the parametrization
#' of Kadane et al. (1980).
#'
#' @details Let `rho0 = p(xmin)` be the probability of a DLT at the minimum dose
#'   `xmin`, and let `gamma` be the dose with target toxicity probability `theta`,
#'   i.e. \eqn{p(gamma) = theta}. Then it can easily be shown that the logistic
#'   regression model has intercept
#'   \deqn{[gamma * logit(rho0) - xmin * logit(theta)] / [gamma - xmin]}
#'   and slope
#'   \deqn{[logit(theta) - logit(rho0)] / [gamma - xmin].}
#'
#'   The priors are \deqn{gamma ~ Unif(xmin, xmax).} and
#'   \deqn{rho0 ~ Unif(0, theta).}
#'
#' @note The slots of this class, required for creating the model, are the target
#'   toxicity, as well as the minimum and maximum of the dose range. Note that
#'   these can be different from the minimum and maximum of the dose grid in the
#'   data later on.
#'
#' @slot theta (`proportion`)\cr the target toxicity probability.
#' @slot xmin (`number`)\cr the minimum of the dose range.
#' @slot xmax (`number`)\cr the maximum of the dose range.
#'
#' @seealso [`ModelLogNormal`]
#'
#' @aliases LogisticKadane
#' @export
#'
.LogisticKadane <- setClass(
  Class = "LogisticKadane",
  contains = "GeneralModel",
  slots = c(
    theta = "numeric",
    xmin = "numeric",
    xmax = "numeric"
  ),
  prototype = prototype(
    theta = 0.3,
    xmin = 0.1,
    xmax = 1
  ),
  validity = v_model_logistic_kadane
)

## constructor ----

#' @rdname LogisticKadane-class
#'
#' @param theta (`proportion`)\cr the target toxicity probability.
#' @param xmin (`number`)\cr the minimum of the dose range.
#' @param xmax (`number`)\cr the maximum of the dose range.
#'
#' @export
#' @example examples/Model-class-LogisticKadane.R
#'
LogisticKadane <- function(theta, xmin, xmax) {
  .LogisticKadane(
    theta = theta,
    xmin = xmin,
    xmax = xmax,
    datamodel = function() {
      for (i in 1:nObs) {
        logit(p[i]) <- (1 / (gamma - xmin)) *
          (gamma * logit(rho0) - xmin * logit(theta) + x[i] * (logit(theta) - logit(rho0)))
        y[i] ~ dbern(p[i])
      }
    },
    priormodel = function() {
      rho0 ~ dunif(0, theta)
      gamma ~ dunif(xmin, xmax)
    },
    modelspecs = function() {
      list(theta = theta, xmin = xmin, xmax = xmax)
    },
    init = function() {
      list(rho0 = theta / 10, gamma = (xmax - xmin) / 2)
    },
    datanames = c("nObs", "y", "x"),
    sample = c("rho0", "gamma")
  )
}

## default constructor ----

#' @rdname LogisticKadane-class
#' @note Typically, end-users will not use the `.DefaultLogisticKadane()` function.
#' @export
.DefaultLogisticKadane <- function() {
  LogisticKadane(theta = 0.33, xmin = 1, xmax = 200)
}


# LogisticKadaneBetaGamma ----

## class ----

#' `LogisticKadaneBetaGamma`
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' [`LogisticKadaneBetaGamma`] is the class for the logistic model in the parametrization
#' of Kadane et al. (1980), using a beta and a gamma distribution as the model priors.
#'
#' @details Let `rho0 = p(xmin)` be the probability of a DLT at the minimum dose
#'   `xmin`, and let `gamma` be the dose with target toxicity probability `theta`,
#'   i.e. \eqn{p(gamma) = theta}. Then it can easily be shown that the logistic
#'   regression model has intercept
#'   \deqn{[gamma * logit(rho0) - xmin * logit(theta)] / [gamma - xmin]}
#'   and slope
#'   \deqn{[logit(theta) - logit(rho0)] / [gamma - xmin].}
#'
#'   The prior for `gamma`, is \deqn{gamma ~ Gamma(shape, rate).}.
#'   The prior for `rho0 = p(xmin)`, is \deqn{rho0 ~ Beta(alpha, beta).}
#'
#' @note The slots of this class, required for creating the model, are the same
#'   as in the `LogisticKadane` class. In addition, the shape parameters of the
#'   Beta prior distribution of `rho0` and the shape and rate parameters of the
#'   Gamma prior distribution of `gamma`, are required for creating the prior model.
#'
#' @slot theta (`proportion`)\cr the target toxicity probability.
#' @slot xmin (`number`)\cr the minimum of the dose range.
#' @slot xmax (`number`)\cr the maximum of the dose range.
#' @slot alpha (`number`)\cr the first shape parameter of the Beta prior distribution
#'   of `rho0 = p(xmin)` the probability of a DLT at the minimum dose `xmin`.
#' @slot beta (`number`)\cr the second shape parameter of the Beta prior distribution
#'   of `rho0 = p(xmin)` the probability of a DLT at the minimum dose `xmin`.
#' @slot shape (`number`)\cr the shape parameter of the Gamma prior distribution
#'   of `gamma` the dose with target toxicity probability `theta`.
#' @slot rate (`number`)\cr the rate parameter of the Gamma prior distribution
#'   of `gamma` the dose with target toxicity probability `theta`.
#'
#' @seealso [`ModelLogNormal`], [`LogisticKadane`].
#'
#' @aliases LogisticKadaneBetaGamma
#' @export
#'
.LogisticKadaneBetaGamma <- setClass(
  Class = "LogisticKadaneBetaGamma",
  contains = "LogisticKadane",
  slots = c(
    alpha = "numeric",
    beta = "numeric",
    shape = "numeric",
    rate = "numeric"
  ),
  prototype = prototype(
    theta = 0.3,
    xmin = 0.1,
    xmax = 1,
    alpha = 1,
    beta = 0.5,
    shape = 1.2,
    rate = 2.5
  ),
  validity = v_model_logistic_kadane_beta_gamma
)

## constructor ----

#' @rdname LogisticKadaneBetaGamma-class
#'
#' @inheritParams LogisticKadane
#'
#' @param alpha (`number`)\cr the first shape parameter of the Beta prior distribution
#'   `rho0 = p(xmin)` the probability of a DLT at the minimum dose `xmin`.
#' @param beta (`number`)\cr the second shape parameter of the Beta prior distribution
#'   `rho0 = p(xmin)` the probability of a DLT at the minimum dose `xmin`.
#' @param shape (`number`)\cr the shape parameter of the Gamma prior distribution
#'   `gamma` the dose with target toxicity probability `theta`.
#' @param rate (`number`)\cr the rate parameter of the Gamma prior distribution
#'   `gamma` the dose with target toxicity probability `theta`.
#'
#' @export
#' @example examples/Model-class-LogisticKadaneBetaGamma.R
#'
LogisticKadaneBetaGamma <- function(theta, xmin, xmax, alpha, beta, shape, rate) {
  model_lk <- LogisticKadane(theta = theta, xmin = xmin, xmax = xmax)
  .LogisticKadaneBetaGamma(
    model_lk,
    alpha = alpha,
    beta = beta,
    shape = shape,
    rate = rate,
    priormodel = function() {
      rho0 ~ dbeta(alpha, beta)
      gamma ~ dgamma(shape, rate)
      lowestdose <- xmin
      highestdose <- xmax
      DLTtarget <- theta
    },
    modelspecs = function() {
      list(
        theta = theta,
        xmin = xmin,
        xmax = xmax,
        alpha = alpha,
        beta = beta,
        shape = shape,
        rate = rate
      )
    }
  )
}

## default constructor ----

#' @rdname LogisticKadaneBetaGamma-class
#' @note Typically, end users will not use the `.Default()` function.
#' @export
.DefaultLogisticKadaneBetaGamma <- function() {
  LogisticKadaneBetaGamma(
    theta = 0.3,
    xmin = 0,
    xmax = 7,
    alpha = 1,
    beta = 19,
    shape = 0.5625,
    rate = 0.125
  )
}

# LogisticNormalMixture ----

## class ----

#' `LogisticNormalMixture`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`LogisticNormalMixture`] is the class for standard logistic regression model
#' with a mixture of two bivariate normal priors on the intercept and slope parameters.
#'
#' @details The covariate is the natural logarithm of the dose \eqn{x} divided by
#'   the reference dose \eqn{x*}, i.e.:
#'   \deqn{logit[p(x)] = alpha0 + alpha1 * log(x/x*),}
#'   where \eqn{p(x)} is the probability of observing a DLT for a given dose \eqn{x}.
#'   The prior
#'   \deqn{(alpha0, alpha1) ~ w * Normal(mean1, cov1) + (1 - w) * Normal(mean2, cov2).}
#'   The weight w for the first component is assigned a beta prior `B(a, b)`.
#'
#' @note The weight of the two normal priors is a model parameter, hence it is a
#'   flexible mixture. This type of prior is often used with a mixture of a minimal
#'   informative and an informative component, in order to make the CRM more robust
#'   to data deviations from the informative component.
#'
#' @slot comp1 (`ModelParamsNormal`)\cr bivariate normal prior specification of
#'   the first component.
#' @slot comp2 (`ModelParamsNormal`)\cr bivariate normal prior specification of
#'   the second component.
#' @slot weightpar (`numeric`)\cr the beta parameters for the weight of the
#'   first component. It must a be a named vector of length 2 with names `a` and
#'   `b` and with strictly positive values.
#' @slot ref_dose (`positive_number`)\cr the reference dose.
#'
#' @seealso [`ModelParamsNormal`], [`ModelLogNormal`],
#'   [`LogisticNormalFixedMixture`], [`LogisticLogNormalMixture`].
#'
#' @aliases LogisticNormalMixture
#' @export
#'
.LogisticNormalMixture <- setClass(
  Class = "LogisticNormalMixture",
  contains = "GeneralModel",
  slots = c(
    comp1 = "ModelParamsNormal",
    comp2 = "ModelParamsNormal",
    weightpar = "numeric",
    ref_dose = "numeric"
  ),
  prototype = prototype(
    comp1 = ModelParamsNormal(mean = c(0, 1), cov = diag(2)),
    comp2 = ModelParamsNormal(mean = c(-1, 1), cov = diag(2)),
    weightpar = c(a = 1, b = 1),
    ref_dose = 1
  ),
  validity = v_model_logistic_normal_mix
)

## constructor ----

#' @rdname LogisticNormalMixture-class
#'
#' @param comp1 (`ModelParamsNormal`)\cr bivariate normal prior specification of
#'   the first component. See [`ModelParamsNormal`] for more details.
#' @param comp2 (`ModelParamsNormal`)\cr bivariate normal prior specification of
#'   the second component. See [`ModelParamsNormal`] for more details.
#' @param weightpar (`numeric`)\cr the beta parameters for the weight of the
#'   first component. It must a be a named vector of length 2 with names `a` and
#'   `b` and with strictly positive values.
#' @param ref_dose (`number`)\cr the reference dose \eqn{x*}
#'   (strictly positive number).
#'
#' @export
#' @example examples/Model-class-LogisticNormalMixture.R
#'
LogisticNormalMixture <- function(comp1,
                                  comp2,
                                  weightpar,
                                  ref_dose) {
  assert_number(ref_dose)

  .LogisticNormalMixture(
    comp1 = comp1,
    comp2 = comp2,
    weightpar = weightpar,
    ref_dose = ref_dose,
    datamodel = function() {
      # The logistic likelihood - the same as for non-mixture case.
      for (i in 1:nObs) {
        logit(p[i]) <- alpha0 + alpha1 * log(x[i] / ref_dose)
        y[i] ~ dbern(p[i])
      }
    },
    priormodel = function() {
      w ~ dbeta(weightpar[1], weightpar[2])
      wc <- 1 - w
      comp0 ~ dbern(wc)
      comp <- comp0 + 1
      # Conditional on the component index "comp", which is  1 or 2.
      # comp = 1 with probability "w" and comp = 2 with probability "1 - w".
      theta ~ dmnorm(mean[1:2, comp], prec[1:2, 1:2, comp])
      alpha0 <- theta[1]
      alpha1 <- theta[2]
    },
    modelspecs = function(from_prior) {
      ms <- list(
        mean = cbind(comp1@mean, comp2@mean),
        prec = array(data = c(comp1@prec, comp2@prec), dim = c(2, 2, 2)),
        weightpar = weightpar
      )
      if (!from_prior) {
        ms$ref_dose <- ref_dose
      }
      ms
    },
    init = function() {
      list(theta = c(0, 1))
    },
    datanames = c("nObs", "y", "x"),
    sample = c("alpha0", "alpha1", "w")
  )
}

## default constructor ----

#' @rdname LogisticNormalMixture-class
#' @note Typically, end-users will not use the `.DefaultLogisticNormalMixture()` function.
#' @export
.DefaultLogisticNormalMixture <- function() { # nolint
  LogisticNormalMixture(
    comp1 = ModelParamsNormal(
      mean = c(-0.85, 1),
      cov = matrix(c(1, -0.5, -0.5, 1), nrow = 2)
    ),
    comp2 = ModelParamsNormal(
      mean = c(1, 1.5),
      cov = matrix(c(1.2, -0.45, -0.45, 0.6), nrow = 2)
    ),
    weightpar = c(a = 1, b = 1),
    ref_dose = 50
  )
}

# LogisticNormalFixedMixture ----

## class ----

#' `LogisticNormalFixedMixture`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`LogisticNormalFixedMixture`] is the class for standard logistic regression
#' model with fixed mixture of multiple bivariate (log) normal priors on the
#' intercept and slope parameters. The weights of the normal priors are fixed,
#' hence no additional model parameters are introduced. This type of prior is
#' often used to better approximate a given posterior distribution, or when the
#' information is given in terms of a mixture.
#'
#' @details The covariate is the natural logarithm of the dose \eqn{x} divided
#'   by the reference dose \eqn{x*}, i.e.:
#'   \deqn{logit[p(x)] = alpha0 + alpha1 * log(x/x*),}
#'   where \eqn{p(x)} is the probability of observing a DLT for a given dose \eqn{x}.
#'   The prior
#'   \deqn{(alpha0, alpha1) ~ w1 * Normal(mean1, cov1) + ... + wK * Normal(meanK, covK),}
#'   if a normal prior is used and
#'   \deqn{(alpha0, log(alpha1)) ~ w1 * Normal(mean1, cov1) + ... + wK * Normal(meanK, covK),}
#'   if a log normal prior is used.
#'   The weights \eqn{w1, ..., wK} of the components are fixed and sum to 1.
#'
#'   The slots of this class comprise a list with components parameters. Every
#'   single component contains the mean vector and the covariance matrix of
#'   bivariate normal distributions. Remaining slots are the weights of the
#'   components as well as the reference dose. Moreover, a special indicator
#'   slot specifies whether a log normal prior is used.
#'
#' @slot components (`list`)\cr the specifications of the mixture components,
#'   a list with [`ModelParamsNormal`] objects for each bivariate (log) normal
#'   prior.
#' @slot weights (`numeric`)\cr the weights of the components; these must be
#'   positive and must sum to 1.
#' @slot ref_dose (`positive_number`)\cr the reference dose.
#' @slot log_normal (`flag`)\cr should a log normal prior be used, such
#'   that the mean vectors and covariance matrices are valid for the intercept
#'   and log slope?
#'
#' @seealso [`ModelParamsNormal`], [`ModelLogNormal`],
#'   [`LogisticNormalMixture`], [`LogisticLogNormalMixture`].
#'
#' @aliases LogisticNormalFixedMixture
#' @export
#'
.LogisticNormalFixedMixture <- setClass(
  Class = "LogisticNormalFixedMixture",
  contains = "GeneralModel",
  slots = c(
    components = "list",
    weights = "numeric",
    ref_dose = "numeric",
    log_normal = "logical"
  ),
  prototype = prototype(
    components = list(
      comp1 = ModelParamsNormal(mean = c(0, 1), cov = diag(2)),
      comp2 = ModelParamsNormal(mean = c(-1, 1), cov = diag(2))
    ),
    weights = c(0.5, 0.5),
    ref_dose = 1,
    log_normal = FALSE
  ),
  validity = v_model_logistic_normal_fixed_mix
)

## constructor ----

#' @rdname LogisticNormalFixedMixture-class
#'
#' @param components (`list`)\cr the specifications of the mixture components,
#'   a list with [`ModelParamsNormal`] objects for each bivariate (log) normal
#'   prior.
#' @param weights (`numeric`)\cr the weights of the components; these must be
#'   positive and will be normalized to sum to 1.
#' @param ref_dose (`number`)\cr the reference dose \eqn{x*}
#'   (strictly positive number).
#' @param log_normal (`flag`)\cr should a log normal prior be specified, such
#'   that the mean vectors and covariance matrices are valid for the intercept
#'   and log slope?
#'
#' @export
#' @example examples/Model-class-LogisticNormalFixedMixture.R
#'
LogisticNormalFixedMixture <- function(components,
                                       weights,
                                       ref_dose,
                                       log_normal = FALSE) {
  assert_numeric(weights)
  assert_number(ref_dose)
  assert_flag(log_normal)

  # Normalize weights to sum to 1.
  weights <- weights / sum(weights)

  .LogisticNormalFixedMixture(
    components = components,
    weights = weights,
    ref_dose = positive_number(ref_dose),
    log_normal = log_normal,
    datamodel = function() {
      for (i in 1:nObs) {
        logit(p[i]) <- alpha0 + alpha1 * log(x[i] / ref_dose)
        y[i] ~ dbern(p[i])
      }
    },
    priormodel = if (log_normal) {
      function() {
        comp ~ dcat(weights)
        theta ~ dmnorm(mean[1:2, comp], prec[1:2, 1:2, comp])
        alpha0 <- theta[1]
        alpha1 <- exp(theta[2])
      }
    } else {
      function() {
        comp ~ dcat(weights)
        theta ~ dmnorm(mean[1:2, comp], prec[1:2, 1:2, comp])
        alpha0 <- theta[1]
        alpha1 <- theta[2]
      }
    },
    modelspecs = function(from_prior) {
      ms <- list(
        weights = weights,
        mean = do.call(cbind, lapply(components, h_slots, "mean", simplify = TRUE)),
        prec = array(
          do.call(c, lapply(components, h_slots, "prec", simplify = TRUE)),
          dim = c(2, 2, length(components))
        )
      )
      if (!from_prior) {
        ms$ref_dose <- ref_dose
      }
      ms
    },
    init = function() {
      list(theta = c(0, 1))
    },
    datanames = c("nObs", "y", "x"),
    sample = c("alpha0", "alpha1")
  )
}

## default constructor ----

#' @rdname LogisticNormalFixedMixture-class
#' @note Typically, end-users will not use the `.DefaultLogisticNormalFixedMixture()`
#' function.
#' @export
.DefaultLogisticNormalFixedMixture <- function() { # nolint
  LogisticNormalFixedMixture(
    components = list(
      comp1 = ModelParamsNormal(
        mean = c(-0.85, 1),
        cov = matrix(c(1, -0.5, -0.5, 1), nrow = 2)
      ),
      comp2 = ModelParamsNormal(
        mean = c(1, 1.5),
        cov = matrix(c(1.2, -0.45, -0.45, 0.6), nrow = 2)
      )
    ),
    weights = c(0.3, 0.7),
    ref_dose = 50
  )
}

# LogisticLogNormalMixture ----

## class ----

#' `LogisticLogNormalMixture`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`LogisticLogNormalMixture`] is the class for standard logistic model with
#' online mixture of two bivariate log normal priors.
#'
#' @details This model can be used when data is arising online from the informative
#'   component of the prior, at the same time with the data of the trial of
#'   main interest. Formally, this is achieved by assuming that the probability
#'   of a DLT at dose \eqn{x} is given by
#'   \deqn{p(x) = \pi * p1(x) + (1 - \pi) * p2(x)}
#'   where \eqn{\pi} is the probability for the model \eqn{p(x)} being the same
#'   as the model \eqn{p1(x)}, which is the informative component of the prior.
#'   From this model data arises in parallel: at doses `xshare`, DLT information
#'   `yshare` is observed, in total `nObsshare` data points (see [`DataMixture`]).
#'   On the other hand, \eqn{1 - \pi}, is the probability of a separate model
#'   \eqn{p2(x)}. Both components have the same log normal prior distribution,
#'   which can be specified by the user, and which is inherited from the
#'   [`LogisticLogNormal`] class.
#'
#' @slot share_weight (`proportion`)\cr the prior weight for the share component
#'   \eqn{p_{1}(x)}.
#'
#' @seealso [`ModelLogNormal`], [`LogisticNormalMixture`],
#'   [`LogisticNormalFixedMixture`].
#'
#' @aliases LogisticLogNormalMixture
#' @export
#'
.LogisticLogNormalMixture <- setClass(
  Class = "LogisticLogNormalMixture",
  contains = "LogisticLogNormal",
  slots = c(
    share_weight = "numeric"
  ),
  prototype = prototype(
    share_weight = 0.1
  ),
  validity = v_model_logistic_log_normal_mix
)

## constructor ----

#' @rdname LogisticLogNormalMixture-class
#'
#' @inheritParams ModelLogNormal
#' @param share_weight (`proportion`)\cr the prior weight for the share component.
#'
#' @export
#' @example examples/Model-class-LogisticLogNormalMixture.R
#'
LogisticLogNormalMixture <- function(mean,
                                     cov,
                                     ref_dose,
                                     share_weight) {
  assert_number(ref_dose)

  params <- ModelParamsNormal(mean, cov)
  .LogisticLogNormalMixture(
    params = params,
    ref_dose = positive_number(ref_dose),
    share_weight = share_weight,
    datamodel = function() {
      for (i in 1:nObs) {
        # comp gives the component: non-informative (1) or share (2) the two components.
        stand_log_dose[i] <- log(x[i] / ref_dose)
        logit(p[i]) <- alpha0[comp] + alpha1[comp] * stand_log_dose[i]
        y[i] ~ dbern(p[i])
      }
      for (j in 1:nObsshare) {
        stand_log_dose_share[j] <- log(xshare[j] / ref_dose)
        logit(pshare[j]) <- alpha0[2] + alpha1[2] * stand_log_dose_share[j]
        yshare[j] ~ dbern(pshare[j])
      }
    },
    priormodel = function() {
      for (k in 1:2) {
        theta[k, 1:2] ~ dmnorm(mean, prec)
        alpha0[k] <- theta[k, 1]
        alpha1[k] <- exp(theta[k, 2])
      }
      # The component indicator.
      comp ~ dcat(cat_probs)
    },
    modelspecs = function(from_prior) {
      ms <- list(
        cat_probs = c(1 - share_weight, share_weight),
        mean = params@mean,
        prec = params@prec
      )
      if (!from_prior) {
        ms$ref_dose <- ref_dose
      }
      ms
    },
    init = function() {
      list(theta = matrix(c(0, 0, 1, 1), nrow = 2))
    },
    datanames = c("nObs", "y", "x", "nObsshare", "yshare", "xshare"),
    sample = c("alpha0", "alpha1", "comp")
  )
}

## default constructor ----

#' @rdname LogisticLogNormalMixture-class
#' @note Typically, end users will not use the `.DefaultLogNormalMixture()` function.
#' @export
.DefaultLogisticLogNormalMixture <- function() { # nolint
  LogisticLogNormalMixture(
    share_weight = 0.1,
    mean = c(-0.85, 1),
    cov = matrix(c(1, -0.5, -0.5, 1), nrow = 2),
    ref_dose = 50
  )
}

# DualEndpoint ----

## class ----

#' `DualEndpoint`
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' [`DualEndpoint`] is the general class for the dual endpoint model.
#'
#' @details The idea of the dual-endpoint models is to model not only the
#'   dose-toxicity relationship, but also to model, at the same time, the
#'   relationship of a PD biomarker with the dose. The sub-classes of this class
#'   define how the dose-biomarker relationship is parametrized. This class here
#'   shall contain all the common features to reduce duplicate code.
#'   (This class however, must not be virtual as we need to create objects
#'   of it during the construction of subclass objects.)
#'
#'   The dose-toxicity relationship is modeled with probit regression model
#'   \deqn{probit[p(x)] = betaZ1 + betaZ2 * x/x*,}
#'   or
#'   \deqn{probit[p(x)] = betaZ1 + betaZ2 * log(x/x*),}
#'   in case when the option `use_log_dose` is `TRUE`.
#'   Here, \eqn{p(x)} is the probability of observing a DLT for a given
#'   dose \eqn{x} and \eqn{x*} is the reference dose.
#'   The prior \deqn{(betaZ1, log(betaZ2)) ~ Normal(mean, cov).}
#'
#'   For the biomarker response \eqn{w} at a dose \eqn{x}, we assume
#'   \deqn{w(x) ~ Normal(f(x), sigma2W),}
#'   where \eqn{f(x)} is a function of the dose \eqn{x}, which is further
#'   specified in sub-classes. The biomarker variance \eqn{sigma2W} can be fixed
#'   or assigned an Inverse-Gamma prior distribution; see the details below under
#'   slot `sigma2W`.
#'
#'   Finally, the two endpoints \eqn{y} (the binary DLT variable) and \eqn{w}
#'   (the biomarker) can be correlated, by assuming a correlation of level
#'   \eqn{rho} between the underlying continuous latent toxicity variable \eqn{z}
#'   and the biomarker \eqn{w}. Again, this correlation can be fixed or assigned
#'   a prior distribution from the scaled Beta family; see the details below
#'   under slot `rho`.
#'
#'   Please see the example vignette by typing `crmPackExample()` for a full example.
#'
#' @slot betaZ_params (`ModelParamsNormal`)\cr for the probit toxicity model, it
#'   contains the prior mean, covariance matrix and precision matrix which is
#'   internally calculated as an inverse of the covariance matrix.
#' @slot ref_dose (`positive_number`)\cr for the probit toxicity model, the
#'   reference dose.
#' @slot use_log_dose (`flag`)\cr for the probit toxicity model, whether a log
#'   transformation of the (standardized) dose should be used?
#' @slot sigma2W (`numeric`)\cr the biomarker variance. Either a fixed value or
#'   Inverse-Gamma distribution parameters, i.e. vector with two elements named
#'   `a` and `b`.
#' @slot rho (`numeric`)\cr either a fixed value for the correlation
#'   (between `-1` and `1`), or a named vector with two elements named `a` and `b`
#'   for the Beta prior on the transformation `kappa = (rho + 1) / 2`, which is
#'   in `(0, 1)`. For example, `a = 1, b = 1` leads to a uniform prior on `rho`.
#' @slot use_fixed (`logical`)\cr indicates whether a fixed value for `sigma2W`
#'   or `rho` (for each parameter separately) is used or not. This slot is
#'   needed for internal purposes and must not be touched by the user.
#'
#' @seealso [`DualEndpointRW`], [`DualEndpointBeta`], [`DualEndpointEmax`].
#'
#' @aliases DualEndpoint
#' @export
#'
.DualEndpoint <- setClass(
  Class = "DualEndpoint",
  slots = c(
    betaZ_params = "ModelParamsNormal",
    ref_dose = "positive_number",
    use_log_dose = "logical",
    sigma2W = "numeric",
    rho = "numeric",
    use_fixed = "logical"
  ),
  prototype = prototype(
    betaZ_params = ModelParamsNormal(mean = c(0, 1), cov = diag(2)),
    ref_dose = positive_number(1),
    use_log_dose = FALSE,
    sigma2W = 1,
    rho = 0,
    use_fixed = c(sigma2W = TRUE, rho = TRUE)
  ),
  contains = "GeneralModel",
  validity = v_model_dual_endpoint
)

## constructor ----

#' @rdname DualEndpoint-class
#'
#' @param mean (`numeric`)\cr for the probit toxicity model, the prior mean vector.
#' @param cov (`matrix`)\cr for the probit toxicity model, the prior covariance
#'   matrix. The precision matrix is internally calculated as an inverse of `cov`.
#' @param ref_dose (`number`)\cr for the probit toxicity model, the reference
#'   dose \eqn{x*} (strictly positive number).
#' @param use_log_dose (`flag`)\cr for the probit toxicity model, whether a log
#'   transformation of the (standardized) dose should be used?
#' @param sigma2W (`numeric`)\cr the biomarker variance. Either a fixed value or
#'   Inverse-Gamma distribution parameters, i.e. vector with two elements named
#'   `a` and `b`.
#' @param rho (`numeric`)\cr either a fixed value for the correlation
#'   (between `-1` and `1`), or a named vector with two elements named `a` and `b`
#'   for the Beta prior on the transformation `kappa = (rho + 1) / 2`, which is
#'   in `(0, 1)`. For example, `a = 1, b = 1` leads to a uniform prior on `rho`.
#'
#' @export
#'
DualEndpoint <- function(mean,
                         cov,
                         ref_dose = 1,
                         use_log_dose = FALSE,
                         sigma2W,
                         rho) {
  assert_number(ref_dose)
  assert_numeric(sigma2W, min.len = 1, max.len = 2)
  assert_numeric(rho, min.len = 1, max.len = 2)

  use_fixed <- c(
    sigma2W = test_number(sigma2W),
    rho = test_number(rho)
  )
  beta_z_params <- ModelParamsNormal(mean, cov)

  datamodel <- function() {
    for (i in 1:nObs) {
      # The toxicity model.
      stand_dose_temp[i] <- x[i] / ref_dose
      stand_dose[i] <- ifelse(use_log_dose, log(stand_dose_temp[i]), stand_dose_temp[i])
      meanZ[i] <- betaZ[1] + betaZ[2] * stand_dose[i]
      z[i] ~ dnorm(meanZ[i], 1)
      y[i] ~ dinterval(z[i], 0)

      # The conditional biomarker model; betaW defined in subclasses!
      condMeanW[i] <- betaW[xLevel[i]] + rho / sqrt(precW) * (z[i] - meanZ[i])
      w[i] ~ dnorm(condMeanW[i], condPrecW)
    }
  }
  priormodel <- function() {
    # Priors for betaW defined in subclasses!
    theta ~ dmnorm(betaZ_mean, betaZ_prec)
    betaZ[1] <- theta[1]
    betaZ[2] <- exp(theta[2])
    # Conditional precision for biomarker.
    # Code for `precW` and `rho` will be added by
    # `h_model_dual_endpoint_sigma2W()`, `h_model_dual_endpoint_rho()` helpers, below.
    condPrecW <- precW / (1 - pow(rho, 2))
  }
  modelspecs_prior <- list(
    betaZ_mean = beta_z_params@mean,
    betaZ_prec = beta_z_params@prec
  )

  comp <- list(
    priormodel = priormodel,
    modelspecs = modelspecs_prior,
    init = NULL,
    sample = "betaZ"
  )

  # Update model components with regard to biomarker regression variance.
  comp <- h_model_dual_endpoint_sigma2W(
    use_fixed["sigma2W"],
    sigma2W = sigma2W,
    comp = comp
  )

  # Update model components with regard to DLT and biomarker correlation.
  comp <- h_model_dual_endpoint_rho(
    use_fixed["rho"],
    rho = rho,
    comp = comp
  )

  .DualEndpoint(
    betaZ_params = beta_z_params,
    ref_dose = positive_number(ref_dose),
    use_log_dose = use_log_dose,
    sigma2W = sigma2W,
    rho = rho,
    use_fixed = use_fixed,
    datamodel = datamodel,
    priormodel = comp$priormodel,
    modelspecs = function(from_prior) {
      if (!from_prior) {
        comp$modelspecs$ref_dose <- ref_dose
        comp$modelspecs$use_log_dose <- use_log_dose
      }
      comp$modelspecs
    },
    init = function(y) {
      c(comp$init, list(z = ifelse(y == 0, -1, 1), theta = c(0, 1)))
    },
    datanames = c("nObs", "w", "x", "xLevel", "y"),
    sample = comp$sample
  )
}

## default constructor ----

#' @rdname DualEndpoint-class
#' @note Typically, end users will not use the `.DefaultDualEndpoint()` function.
#' @export
.DefaultDualEndpoint <- function() {
  stop(paste0("Class DualEndpoint cannot be instantiated directly.  Please use one of its subclasses instead."))
}

# DualEndpointRW ----

## class ----

#' `DualEndpointRW`
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' [`DualEndpointRW`] is the class for the dual endpoint model with random walk
#' prior for biomarker.
#'
#'
#' @details This class extends the [`DualEndpoint`] class so that the dose-biomarker
#'   relationship \eqn{f(x)} is modelled by a non-parametric random walk of first
#'   or second order. That means, for the first order random walk we assume
#'   \deqn{betaW_i - betaW_i-1 ~ Normal(0, (x_i - x_i-1) * sigma2betaW),}
#'   where \eqn{betaW_i = f(x_i)} is the biomarker mean at the \eqn{i}-th dose
#'   gridpoint \eqn{x_i}.
#'   For the second order random walk, the second-order differences instead of
#'   the first-order differences of the biomarker means follow the normal distribution
#'   with \eqn{0} mean and \eqn{2 * (x_i - x_i-2) * sigma2betaW} variance.
#'
#'   The variance parameter \eqn{sigma2betaW} is important because it steers the
#'   smoothness of the function \eqn{f(x)}, i.e.: if it is large, then \eqn{f(x)}
#'   will be very wiggly; if it is small, then \eqn{f(x)} will be smooth.
#'   This parameter can either be a fixed value or assigned an inverse gamma prior
#'   distribution.
#'
#' @note Non-equidistant dose grids can be used now, because the difference
#'   \eqn{x_i - x_i-1} is included in the modelling assumption above.
#'   Please note that due to impropriety of the random walk prior distributions,
#'   it is not possible to produce MCMC samples with empty data objects (i.e.,
#'   sample from the prior). This is not a bug, but a theoretical feature of this
#'   model.
#'
#' @slot sigma2betaW (`numeric`)\cr the prior variance factor of the random walk
#'   prior for the biomarker model. Either a fixed value or Inverse-Gamma distribution
#'   parameters, i.e. vector with two elements named `a` and `b`.
#' @slot rw1 (`flag`)\cr for specifying the random walk prior on the biomarker
#'   level. When `TRUE`, random walk of first order is used. Otherwise, the
#'   random walk of second order is used.
#'
#' @seealso [`DualEndpoint`], [`DualEndpointBeta`], [`DualEndpointEmax`].
#'
#' @aliases DualEndpointRW
#' @export
#'
.DualEndpointRW <- setClass(
  Class = "DualEndpointRW",
  slots = c(
    sigma2betaW = "numeric",
    rw1 = "logical"
  ),
  prototype = prototype(
    sigma2betaW = 1,
    rw1 = TRUE,
    use_fixed = c(
      sigma2W = TRUE,
      rho = TRUE,
      sigma2betaW = TRUE
    )
  ),
  contains = "DualEndpoint",
  validity = v_model_dual_endpoint_rw
)

## constructor ----

#' @rdname DualEndpointRW-class
#'
#' @param sigma2betaW (`numeric`)\cr the prior variance factor of the random walk
#'   prior for the biomarker model. Either a fixed value or Inverse-Gamma distribution
#'   parameters, i.e. vector with two elements named `a` and `b`.
#' @param rw1 (`flag`)\cr for specifying the random walk prior on the biomarker
#'   level. When `TRUE`, random walk of first order is used. Otherwise, the
#'   random walk of second order is used.
#' @param ... parameters passed to [DualEndpoint()].
#'
#' @export
#' @example examples/Model-class-DualEndpointRW.R
#'
DualEndpointRW <- function(sigma2betaW,
                           rw1 = TRUE,
                           ...) {
  assert_numeric(sigma2betaW, min.len = 1, max.len = 2)
  assert_flag(rw1)

  start <- DualEndpoint(...)
  start@use_fixed["sigma2betaW"] <- length(sigma2betaW) == 1L

  priormodel <- if (rw1) {
    function() {
      # The 1st order differences.
      # Essentially dflat(), which is not available in JAGS.
      betaW[1] ~ dnorm(0, 0.000001)
      for (i in 2:nGrid) {
        delta[i - 1] ~ dnorm(0, precBetaW / (doseGrid[i] - doseGrid[i - 1]))
        betaW[i] <- betaW[i - 1] + delta[i - 1]
      }
    }
  } else {
    function() {
      # The 2nd order differences.
      delta[1] ~ dnorm(0, 0.000001)
      betaW[1] ~ dnorm(0, 0.000001)
      betaW[2] <- betaW[1] + delta[1]
      for (i in 3:nGrid) {
        # delta2: differences of the differences of betaW follow normal dist.
        delta2[i - 2] ~ dnorm(0, 2 * precBetaW / (doseGrid[i] - doseGrid[i - 2]))
        delta[i - 1] <- delta[i - 2] + delta2[i - 2]
        betaW[i] <- betaW[i - 1] + delta[i - 1]
      }
    }
  }
  start@priormodel <- h_jags_join_models(start@priormodel, priormodel)
  start@datanames_prior <- c("nGrid", "doseGrid")
  start@sample <- c(start@sample, "betaW", "delta")

  # Update model components with regard to biomarker regression variance.
  start <- h_model_dual_endpoint_sigma2betaW(
    start@use_fixed["sigma2betaW"],
    sigma2betaW = sigma2betaW,
    de = start
  )

  .DualEndpointRW(
    start,
    sigma2betaW = sigma2betaW,
    rw1 = rw1
  )
}

## default constructor ----

#' @rdname DualEndpointRW-class
#' @note Typically, end users will not use the `.DefaultDualEndpointRW()` function.
#' @export
.DefaultDualEndpointRW <- function() {
  DualEndpointRW(
    mean = c(0, 1),
    cov = matrix(c(1, 0, 0, 1), nrow = 2),
    sigma2W = c(a = 0.1, b = 0.1),
    rho = c(a = 1, b = 1),
    sigma2betaW = 0.01,
    rw1 = TRUE
  )
}

# DualEndpointBeta ----

## class ----

#' `DualEndpointBeta`
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' [`DualEndpointBeta`] is the class for the dual endpoint model with beta
#' function for dose-biomarker relationship.
#'
#' @details This class extends the [`DualEndpoint`] class so that the dose-biomarker
#'   relationship \eqn{f(x)} is modelled by a parametric, rescaled beta density
#'   function:
#'   \deqn{f(x) = E0 + (Emax - E0) * Beta(delta1, delta2) * (x/x*)^delta1 * (1 - x/x*)^delta2,}
#'   where \eqn{x*} is the maximum dose (end of the dose range to be considered),
#'   \eqn{delta1} and \eqn{delta2} are the two beta function parameters, and
#'   \eqn{E0}, \eqn{Emax} are the minimum and maximum levels, respectively.
#'   For ease of interpretation, we use the parametrization based on \eqn{delta1}
#'   and the mode, where
#'   \deqn{mode = delta1 / (delta1 + delta2),}
#'   so that multiplying this by \eqn{x*} gives the mode on the dose grid.
#'
#'   All parameters can currently be assigned uniform distributions or be fixed
#'   in advance. Note that \code{E0} and \code{Emax} can have negative values or
#'   uniform distributions reaching into negative range, while \code{delta1} and
#'   \code{mode} must be positive or have uniform distributions in the positive
#'   range.
#'
#' @slot E0 (`numeric`)\cr either a fixed number or the two uniform distribution
#'   parameters.
#' @slot Emax (`numeric`)\cr either a fixed number or the two uniform
#'   distribution parameters.
#' @slot delta1 (`numeric`)\cr either a fixed positive number or the two
#'   parameters of the uniform distribution, that can take only positive values.
#' @slot mode (`numeric`)\cr either a fixed positive number or the two
#'   parameters of the uniform distribution, that can take only positive values.
#' @slot ref_dose_beta (`positive_number`)\cr the reference dose \eqn{x*} (note
#'   that this is different from the `ref_dose` in the inherited [`DualEndpoint`]
#'   model).
#'
#' @seealso [`DualEndpoint`], [`DualEndpointRW`], [`DualEndpointEmax`].
#'
#' @aliases DualEndpointBeta
#' @export
#'
.DualEndpointBeta <- setClass(
  Class = "DualEndpointBeta",
  slots = c(
    E0 = "numeric",
    Emax = "numeric",
    delta1 = "numeric",
    mode = "numeric",
    ref_dose_beta = "positive_number"
  ),
  prototype = prototype(
    E0 = c(0, 100),
    Emax = c(0, 500),
    delta1 = c(0, 5),
    mode = c(1, 15),
    ref_dose_beta = positive_number(1),
    use_fixed = c(
      sigma2W = TRUE,
      rho = TRUE,
      E0 = FALSE,
      Emax = FALSE,
      delta1 = FALSE,
      mode = FALSE
    )
  ),
  contains = "DualEndpoint",
  validity = v_model_dual_endpoint_beta
)

## constructor ----

#' @rdname DualEndpointBeta-class
#'
#' @param E0 (`numeric`)\cr either a fixed number or the two uniform distribution
#'   parameters.
#' @param Emax (`numeric`)\cr either a fixed number or the two uniform distribution
#'   parameters.
#' @param delta1 (`numeric`)\cr either a fixed positive number or the two parameters
#'   of the uniform distribution, that can take only positive values.
#' @param mode (`numeric`)\cr either a fixed positive number or the two parameters
#'   of the uniform distribution, that can take only positive values.
#' @param ref_dose_beta (`number`)\cr the reference dose \eqn{x*} (strictly
#'   positive number). Note that this is different from the `ref_dose` in the
#'   inherited [`DualEndpoint`] model).
#' @param ... parameters passed to [DualEndpoint()].
#'
#' @export
#' @example examples/Model-class-DualEndpointBeta.R
#'
DualEndpointBeta <- function(E0,
                             Emax,
                             delta1,
                             mode,
                             ref_dose_beta = 1,
                             ...) {
  assert_numeric(E0, min.len = 1, max.len = 2)
  assert_numeric(Emax, min.len = 1, max.len = 2)
  assert_numeric(delta1, min.len = 1, max.len = 2)
  assert_numeric(mode, min.len = 1, max.len = 2)
  assert_number(ref_dose_beta)

  start <- DualEndpoint(...)

  ms <- start@modelspecs
  start@modelspecs <- function(from_prior) {
    c(list(ref_dose_beta = ref_dose_beta), ms(from_prior))
  }
  start@datanames_prior <- c("nGrid", "doseGrid")
  start@sample <- c(start@sample, "betaW")

  start <- h_model_dual_endpoint_beta(
    param = E0,
    param_name = "E0",
    priormodel = function() {
      E0 ~ dunif(E0_low, E0_high)
    },
    de = start
  )

  start <- h_model_dual_endpoint_beta(
    param = Emax,
    param_name = "Emax",
    priormodel = function() {
      Emax ~ dunif(Emax_low, Emax_high)
    },
    de = start
  )

  start <- h_model_dual_endpoint_beta(
    param = delta1,
    param_name = "delta1",
    priormodel = function() {
      delta1 ~ dunif(delta1_low, delta1_high)
    },
    de = start
  )

  start <- h_model_dual_endpoint_beta(
    param = mode,
    param_name = "mode",
    priormodel = function() {
      mode ~ dunif(mode_low, mode_high)
    },
    de = start
  )

  start@priormodel <- h_jags_join_models(
    start@priormodel,
    function() {
      # delta2 <- delta1 * (1 - (mode/ref_dose_beta)) / (mode/ref_dose_beta) # nolint
      delta2 <- delta1 * (ref_dose_beta / mode - 1)
      # betafun <- (delta1 + delta2)^(delta1 + delta2) * delta1^(- delta1) * delta2^(- delta2) # nolint
      betafun <- (1 + delta2 / delta1)^delta1 * (delta1 / delta2 + 1)^delta2
      for (i in 1:nGrid) {
        stand_dose_beta[i] <- doseGrid[i] / ref_dose_beta
        betaW[i] <- E0 + (Emax - E0) * betafun * stand_dose_beta[i]^delta1 * (1 - stand_dose_beta[i])^delta2
      }
    }
  )

  .DualEndpointBeta(
    start,
    E0 = E0,
    Emax = Emax,
    delta1 = delta1,
    mode = mode,
    ref_dose_beta = positive_number(ref_dose_beta)
  )
}

## default constructor ----

#' @rdname DualEndpointBeta-class
#' @note Typically, end users will not use the `.DefaultDualEndpointBeta()` function.
#' @export
.DefaultDualEndpointBeta <- function() {
  DualEndpointBeta(
    mean = c(0, 1),
    cov = matrix(c(1, 0, 0, 1), nrow = 2),
    ref_dose = 10,
    use_log_dose = TRUE,
    sigma2W = c(a = 0.1, b = 0.1),
    rho = c(a = 1, b = 1),
    E0 = c(0, 100),
    Emax = c(0, 500),
    delta1 = c(0, 5),
    mode = c(1, 15),
    ref_dose_beta = 1000
  )
}

# DualEndpointEmax ----

## class ----

#' `DualEndpointEmax`
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' [`DualEndpointEmax`] is the class for the dual endpoint model with `Emax`
#' function for dose-biomarker relationship.
#'
#' @details This class extends the [`DualEndpoint`] class so that the dose-biomarker
#'   relationship \eqn{f(x)} is modelled by a parametric `Emax` function:
#'   \deqn{f(x) = E0 + [(Emax - E0) * (x/x*)]/[ED50 + (x/x*)],}
#'   where \eqn{x*} is a reference dose, \eqn{E0} and \eqn{Emax} are the minimum
#'   and maximum levels for the biomarker, and \eqn{ED50} is the dose achieving
#'   half of the maximum effect \eqn{0.5 * Emax}.
#'   All parameters can currently be assigned uniform distributions or be fixed.
#'
#' @slot E0 (`numeric`)\cr either a fixed number or the two uniform distribution
#'   parameters.
#' @slot Emax (`numeric`)\cr either a fixed number or the two uniform
#'   distribution parameters.
#' @slot ED50 (`numeric`)\cr either a fixed number or the two uniform
#'   distribution parameters.
#' @slot ref_dose_emax (`positive_number`)\cr the reference dose \eqn{x*} (note
#'   that this is different from the `ref_dose` in the inherited [`DualEndpoint`]
#'   model).
#'
#' @seealso [`DualEndpoint`], [`DualEndpointRW`], [`DualEndpointBeta`].
#'
#' @aliases DualEndpointEmax
#' @export
#'
.DualEndpointEmax <- setClass(
  Class = "DualEndpointEmax",
  slots = c(
    E0 = "numeric",
    Emax = "numeric",
    ED50 = "numeric",
    ref_dose_emax = "numeric"
  ),
  prototype = prototype(
    E0 = c(0, 100),
    Emax = c(0, 500),
    ED50 = c(0, 500),
    ref_dose_emax = positive_number(1),
    use_fixed = c(
      sigma2W = TRUE,
      rho = TRUE,
      E0 = FALSE,
      Emax = FALSE,
      ED50 = FALSE
    )
  ),
  contains = "DualEndpoint",
  validity = v_model_dual_endpoint_emax
)

## constructor ----

#' @rdname DualEndpointEmax-class
#'
#' @param E0 (`numeric`)\cr either a fixed number or the two uniform distribution
#'   parameters.
#' @param Emax (`numeric`)\cr either a fixed number or the two uniform distribution
#'   parameters.
#' @param ED50 (`numeric`)\cr either a fixed number or the two uniform distribution
#'   parameters.
#' @param ref_dose_emax (`number`)\cr the reference dose \eqn{x*} (strictly
#'   positive number). Note that this is different from the `ref_dose` in the
#'   inherited [`DualEndpoint`] model).
#' @param ... parameters passed to [DualEndpoint()].
#'
#' @export
#' @example examples/Model-class-DualEndpointEmax.R
#'
DualEndpointEmax <- function(E0,
                             Emax,
                             ED50,
                             ref_dose_emax = 1,
                             ...) {
  assert_numeric(E0, min.len = 1, max.len = 2)
  assert_numeric(Emax, min.len = 1, max.len = 2)
  assert_numeric(ED50, min.len = 1, max.len = 2)
  assert_number(ref_dose_emax)

  start <- DualEndpoint(...)

  start@sample <- c(start@sample, "betaW")
  start@datanames_prior <- c("nGrid", "doseGrid")
  ms <- start@modelspecs
  start@modelspecs <- function(from_prior) {
    c(list(ref_dose_emax = ref_dose_emax), ms(from_prior))
  }

  start <- h_model_dual_endpoint_beta(
    param = E0,
    param_name = "E0",
    priormodel = function() {
      E0 ~ dunif(E0_low, E0_high)
    },
    de = start
  )

  start <- h_model_dual_endpoint_beta(
    param = Emax,
    param_name = "Emax",
    priormodel = function() {
      Emax ~ dunif(Emax_low, Emax_high)
    },
    de = start
  )

  start <- h_model_dual_endpoint_beta(
    param = ED50,
    param_name = "ED50",
    priormodel = function() {
      ED50 ~ dunif(ED50_low, ED50_high)
    },
    de = start
  )

  start@priormodel <- h_jags_join_models(
    start@priormodel,
    function() {
      for (i in 1:nGrid) {
        stand_dose_emax[i] <- doseGrid[i] / ref_dose_emax
        betaW[i] <- E0 + (Emax - E0) * stand_dose_emax[i] / (ED50 + stand_dose_emax[i])
      }
    }
  )

  .DualEndpointEmax(
    start,
    E0 = E0,
    Emax = Emax,
    ED50 = ED50,
    ref_dose_emax = positive_number(ref_dose_emax)
  )
}

## default constructor ----

#' @rdname DualEndpointEmax-class
#' @note Typically, end users will not use the `.DefaultDualEndpointEmax()` function.
#' @export
.DefaultDualEndpointEmax <- function() {
  DualEndpointEmax(
    mean = c(0, 1),
    cov = matrix(c(1, 0, 0, 1), nrow = 2),
    sigma2W = c(a = 0.1, b = 0.1),
    rho = c(a = 1, b = 1),
    E0 = c(0, 100),
    Emax = c(0, 500),
    ED50 = c(10, 200),
    ref_dose_emax = 1000
  )
}

# ModelPseudo ----

## class ----

#' `ModelPseudo`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`ModelPseudo`] is the parent class for models that express their prior in
#' the form of pseudo data (as if there is some data before the trial starts).
#'
#' @seealso [`GeneralModel`].
#'
#' @aliases ModelPseudo
#' @export
#'
.ModelPseudo <- setClass(
  Class = "ModelPseudo",
  contains = "CrmPackClass"
)

## default constructor ----

#' @rdname ModelPseudo-class
#' @note Typically, end users will not use the `.DefaultModelPseudo()` function.
#' @export
.DefaultModelPseudo <- function() {
  stop(paste0("Class ModelPseudo should not be instantiated directly.  Please use one of its subclasses instead."))
}

# ModelTox ----

## class ----

#' `ModelTox`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`ModelTox`] is the parent class for DLE (dose-limiting events) models using
#' pseudo data prior. It is dedicated for DLE models or toxicity models that
#' have their prior specified in the form of pseudo data (as if there is some
#' data before the trial starts).
#'
#' The `data` must obey the convention of the [`Data`] class. This refers to any
#' observed DLE responses (`y` in [`Data`]), the dose levels (`x` in [`Data`])
#' at which these responses are observed, all dose levels considered in the
#' study (`doseGrid` in [`Data`]), and finally other specifications in [`Data`]
#' class that can be used to generate prior or posterior modal estimates or
#' samples estimates for model parameter(s).
#' If no responses are observed, at least `doseGrid` has to be specified
#' in `data` for which prior modal estimates or samples can be obtained for
#' model parameters based on the specified pseudo data.
#'
#' @slot data (`Data`)\cr observed data that is used to obtain model parameters
#'   estimates or samples (see details above).
#'
#' @seealso [`ModelEff`].
#'
#' @aliases ModelTox
#' @export
#'
.ModelTox <- setClass(
  Class = "ModelTox",
  slots = c(
    data = "Data"
  ),
  contains = "ModelPseudo"
)

## default constructor ----

#' @rdname ModelTox-class
#' @note Typically, end users will not use the `.DefaultModelTox()` function.
#' @export
.DefaultModelTox <- function() {
  stop(paste0("Class ModelTox should not be instantiated directly.  Please use one of its subclasses instead."))
}

# ModelEff ----

## class ----

#' `ModelEff`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`ModelEff`] is the parent class for efficacy models using pseudo data prior.
#' It is dedicated all efficacy models that have their prior specified in the
#' form of pseudo data (as if there is some data before the trial starts).
#'
#' The `data` must obey the convention of the [`DataDual`] class. This refers to
#' any observed efficacy/biomarker responses (`w` in [`DataDual`]), the dose
#' levels at which these responses are observed (`x` in [`DataDual`]), all dose
#' levels considered in the study (`doseGrid` in [`DataDual`]), and finally
#' other specifications in [`DataDual`] class that can be used to generate prior
#' or posterior modal estimates or samples estimates for model parameter(s).
#' If no responses are observed, at least `doseGrid` has to be specified
#' in `data` for which prior modal estimates or samples can be obtained for
#' model parameters based on the specified pseudo data.
#'
#' @slot data (`DataDual`)\cr observed data that is used to obtain model
#'   parameters estimates or samples (see details above).
#'
#' @seealso [`ModelTox`].
#'
#' @aliases ModelEff
#' @export
#'
.ModelEff <- setClass(
  Class = "ModelEff",
  slots = c(
    data = "DataDual"
  ),
  contains = "ModelPseudo"
)

## default constructor ----

#' @rdname ModelEff-class
#' @note Typically, end users will not use the `.DefaultModelEff()` function.
#' @export
.DefaultModelEff <- function() {
  stop(paste0("Class ModelEff should not be instantiated directly.  Please use one of its subclasses instead."))
}

# LogisticIndepBeta ----

## class ----

#' `LogisticIndepBeta`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`LogisticIndepBeta`] is the class for the two-parameters logistic regression
#' dose-limiting events (DLE) model with prior expressed in form of pseudo data.
#' This model describes the relationship between the binary DLE responses
#' and the dose levels. More specifically, it represents the relationship of the
#' probabilities of the occurrence of a DLE for corresponding dose levels in log
#' scale. This model is specified as
#' \deqn{p(x) = exp(phi1 + phi2 * log(x)) / (1 + exp(phi1 + phi2 * log(x)))}
#' where \eqn{p(x)} is the probability of the occurrence of a DLE at dose \eqn{x}.
#' The two parameters of this model are the intercept \eqn{phi1} and the slope
#' \eqn{phi2}. The `LogisticIndepBeta` inherits all slots from [`ModelTox`] class.
#'
#' In the context of pseudo data, the following three arguments are used,
#' `binDLE`, `DLEdose` and `DLEweights`. The `DLEdose` represents fixed dose
#' levels at which the pseudo DLE responses `binDLE` are observed. `DLEweights`
#' represents total number of subjects treated per each dose level in `DLEdose`.
#' The `binDLE` represents the number of subjects observed with DLE per each
#' dose level in `DLEdose`. Hence, all these three vectors must be of the same
#' length and the order of the elements in any of the vectors `binDLE`,
#' `DLEdose` and `DLEweights` must be kept, so that an element of a given vector
#' corresponds to the elements of the remaining two vectors (see the example for
#' more insight).
#' Finally, since at least two DLE pseudo responses are needed to
#' obtain prior modal estimates (same as the maximum likelihood estimates) for
#' the model parameters, the `binDLE`, `DLEdose` and `DLEweights` must all be
#' vectors of at least length 2.
#'
#' @details The pseudo data can be interpreted as if we obtain some observations
#'   before the trial starts. It can be used to express our prior, i.e. the
#'   initial beliefs for the model parameters. The pseudo data is expressed in
#'   the following way. First, fix at least two dose levels, then ask for experts'
#'   opinion on how many subjects are to be treated at each of these dose levels
#'   and on the number of subjects observed with a DLE. At each dose level, the
#'   number of subjects observed with a DLE, divided by the total number of
#'   subjects treated, is the probability of the occurrence of a DLE at that
#'   particular dose level. The probabilities of the occurrence of a DLE based
#'   on this pseudo data are independent and they follow Beta distributions.
#'   Therefore, the joint prior probability density function of all these
#'   probabilities can be obtained. Hence, by a change of variable, the joint
#'   prior probability density function of the two parameters in this model can
#'   also be obtained. In addition, a conjugate joint prior density function of
#'   the two parameters in the model is used. For details about the form of all
#'   these joint prior and posterior probability density functions, please refer
#'   to Whitehead and Willamson (1998).
#'
#' @slot binDLE (`numeric`)\cr a vector of total numbers of DLE responses.
#'   It must be at least of length 2 and the order of its elements must
#'   correspond to values specified in `DLEdose` and `DLEweights`.
#' @slot DLEdose (`numeric`)\cr a vector of the dose levels corresponding to
#'   It must be at least of length 2 and the order of its elements must
#'   correspond to values specified in `binDLE` and `DLEweights`.
#' @slot DLEweights (`integer`)\cr total number of subjects treated at each of
#'   the pseudo dose level `DLEdose`.
#'   It must be at least of length 2 and the order of its elements must
#'   correspond to values specified in `binDLE` and `DLEdose`.
#' @slot phi1 (`number`)\cr  the intercept of the model. This slot is used in
#'   output to display the resulting prior or posterior modal estimate of the
#'   intercept obtained based on the pseudo data and (if any) observed data/responses.
#' @slot phi2 (`number`)\cr  the slope of the model. This slot is used in output
#'   to display the resulting prior or posterior modal estimate of the slope
#'   obtained based on the pseudo data and (if any) the observed data/responses.
#' @slot Pcov (`matrix`)\cr refers to the 2x2 covariance matrix of the intercept
#'   (\eqn{phi1}) and the slope parameters (\eqn{phi2}) of the model.
#'   This is used in output to display the resulting prior and posterior
#'   covariance matrix of \eqn{phi1} and \eqn{phi2} obtained, based on the
#'   pseudo data and (if any) the observed data and responses. This slot is
#'   needed for internal purposes.
#'
#' @aliases LogisticIndepBeta
#' @export
#'
.LogisticIndepBeta <- setClass(
  Class = "LogisticIndepBeta",
  slots = c(
    binDLE = "numeric",
    DLEdose = "numeric",
    DLEweights = "integer",
    phi1 = "numeric",
    phi2 = "numeric",
    Pcov = "matrix"
  ),
  prototype = prototype(
    binDLE = c(0, 0),
    DLEdose = c(1, 1),
    DLEweights = c(1L, 1L)
  ),
  contains = "ModelTox",
  validity = v_model_logistic_indep_beta
)

## constructor ----

#' @rdname LogisticIndepBeta-class
#'
#' @param binDLE (`numeric`)\cr the number of subjects observed with a DLE, the
#'   pseudo DLE responses, depending on dose levels `DLEdose`.
#'   Elements of `binDLE` must correspond to the elements of `DLEdose` and
#'   `DLEweights`.
#' @param DLEdose (`numeric`)\cr dose levels for the pseudo DLE responses.
#'   Elements of `DLEdose` must correspond to the elements of `binDLE` and
#'   `DLEweights`.
#' @param DLEweights (`numeric`)\cr the total number of subjects treated at each
#'   of the dose levels `DLEdose`, pseudo weights.
#'   Elements of `DLEweights` must correspond to the elements of `binDLE` and
#'   `DLEdose`.
#' @param data (`Data`)\cr the input data to update estimates of the model
#'   parameters.
#'
#' @export
#' @example examples/Model-class-LogisticIndepBeta.R
#'
LogisticIndepBeta <- function(binDLE,
                              DLEdose,
                              DLEweights,
                              data) {
  assert_numeric(binDLE)
  assert_numeric(DLEdose)
  assert_integerish(DLEweights, lower = 0, any.missing = FALSE)
  assert_class(data, "Data")

  # Combine pseudo and observed data. It can also happen that data@nObs == 0.
  y <- c(binDLE, data@y)
  x <- c(DLEdose, data@x)
  w <- c(DLEweights, rep(1, data@nObs))

  fit_dle <- suppressWarnings(
    glm(y / w ~ log(x), family = binomial(link = "logit"), weights = w)
  )
  phi1 <- coef(fit_dle)[["(Intercept)"]]
  phi2 <- coef(fit_dle)[["log(x)"]]
  Pcov <- vcov(fit_dle)

  .LogisticIndepBeta(
    binDLE = binDLE,
    DLEdose = DLEdose,
    DLEweights = as.integer(DLEweights),
    phi1 = phi1,
    phi2 = phi2,
    Pcov = Pcov,
    data = data
  )
}

## default constructor ----

#' @rdname LogisticIndepBeta-class
#' @note Typically, end users will not use the `.DefaultLogisticIndepBeta()` function.
#' @export
.DefaultLogisticIndepBeta <- function() {
  my_model <- LogisticIndepBeta(
    binDLE = c(1.05, 1.8),
    DLEweights = c(3L, 3L),
    DLEdose = c(25, 300),
    data = Data(doseGrid = seq(25, 300, 25))
  )
}


# Effloglog ----

## class ----

#' `Effloglog`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`Effloglog`] is the class for the linear log-log efficacy model using pseudo
#' data prior. It describes the relationship between continuous efficacy
#' responses and corresponding dose levels in log-log scale. This efficacy
#' log-log model is given as
#' \deqn{y_i = theta1 + theta2 * log(log(x_i)) + epsilon_i,}
#' where \eqn{y_i} is the efficacy response for subject \eqn{i}, \eqn{x_i} is
#' the dose level treated for subject \eqn{i} and \eqn{epsilon_i} is the random
#' error term of efficacy model at subject \eqn{i}. The error term
#' \eqn{epsilon_i} is a random variable that follows normal distribution with
#' mean \eqn{0} and variance \eqn{nu^{-1}}, which is assumed to be the
#' same for all subjects.
#' There are three parameters in this model, the intercept \eqn{theta1}, the
#' slope \eqn{theta2} and the precision \eqn{nu} of the efficacy responses, also
#' known as the inverse of the variance of the pseudo efficacy responses. It can
#' be a fixed constant or having a gamma distribution. Therefore, a single scalar
#' value or a vector with two positive numbers values must be specified for `nu`
#' slot. If there are some observed efficacy responses available, in the output,
#' `nu` will display the updated value of the precision or the updated values
#' for the parameters of the gamma distribution.
#' The `Effloglog` inherits all slots from [`ModelEff`] class.
#'
#' @details The prior of this model is specified in form of pseudo data. First,
#'   at least two dose levels are fixed. Then, using e.g. experts' opinion, the
#'   efficacy values that correspond to these dose levels can be obtained,
#'   The `eff` and `eff_dose` arguments represent the prior in form of the pseudo
#'   data. The `eff` represents the pseudo efficacy values. The `eff_dose`
#'   represents the dose levels at which these pseudo efficacy values are
#'   observed. Hence, the positions of the elements specified in `eff` and
#'   `eff_dose` must correspond to each other between these vectors.
#'   Since at least 2 pseudo efficacy values are needed to obtain modal
#'   estimates of the intercept and slope parameters, both `eff` and `eff_dose`
#'   must be vectors of length at least 2.
#'
#'   The joint prior distribution of the intercept \eqn{theta1} and the slope
#'   \eqn{theta2} of this model follows bivariate normal distribution with mean
#'   \eqn{mu} and covariance matrix \eqn{(nu * Q)^{-1}}.
#'   The mean \eqn{mu} is a \eqn{2 x 1} column vector that contains the prior
#'   modal estimates of the intercept and the slope.
#'   Scalar \eqn{nu} is the precision of the pseudo efficacy responses and
#'   \eqn{Q} is the prior or posterior (given that observed, no DLT data is
#'   available) precision matrix.
#'   It is specified as \eqn{Q = X0^T * X0 + X^T * X}, where \eqn{X0} is a
#'   design matrix that is based on pseudo dose levels only, and \eqn{X} is a
#'   design matrix that is based on dose levels corresponding to the no DLT
#'   efficacy responses observed only (if any).
#'   Hence, the \eqn{X0} (or \eqn{X}) will be of size \eqn{r x 2}, if
#'   there are \eqn{r >= 2} pseudo efficacy responses specified (or
#'   if there are \eqn{r} no DLT efficacy responses observed in the `data`).
#'
#' @slot eff (`numeric`)\cr the pseudo efficacy responses. Each element here
#'   must represent responses treated based on one subject.
#'   It must be a vector of length at least 2 and the order of its elements must
#'   correspond to values specified in `eff_dose`.
#' @slot eff_dose (`numeric`)\cr the pseudo efficacy dose levels at which the
#'   pseudo efficacy responses are observed.
#'   It must be a vector of length at least 2 and the order of its elements must
#'   correspond to values specified in `eff`.
#' @slot nu (`numeric`)\cr parameter of the prior precision of pseudo efficacy
#'   responses. This is either a fixed value or a named vector with two positive
#'   numbers, the shape (`a`), and the rate (`b`) parameters for the gamma
#'   distribution.
#' @slot use_fixed (`flag`)\cr indicates whether `nu` specified is a fixed value
#'   or a vector with two parameters for gamma distribution. This slot is for
#'   internal purposes only and must not be used by the user.
#' @slot theta1 (`number`)\cr the intercept in this efficacy log-log model. This
#'   slot is used in output to display the resulting prior or posterior modal
#'   estimates obtained based on the pseudo and observed (if any) data.
#' @slot theta2 (`number`)\cr the slope in this efficacy log-log model. This
#'   slot is used in output to display the resulting prior or posterior modal
#'   estimates obtained based on the pseudo and observed (if any) data.
#' @slot Pcov (`matrix`)\cr refers to the \eqn{2 x 2} covariance matrix of the
#'   estimators of the intercept \eqn{theta1} and the slope \eqn{theta2}
#'   parameters in this model.
#'   This is used in output to display the resulting prior and posterior
#'   covariance matrix of \eqn{theta1} and \eqn{theta2} obtained, based on the
#'   pseudo and observed (if any) data. This slot is needed for internal purposes.
#' @slot X (`matrix`)\cr is the design matrix that is based on either the pseudo
#'   dose levels or observed dose levels (without DLT). This is used
#'   in the output to display the design matrix for the pseudo or the observed
#'   efficacy responses.
#' @slot Y (`numeric`)\cr is a vector that either contains the pseudo efficacy
#'   responses or observed efficacy responses (without DLT).
#' @slot mu (`numeric`)\cr a vector of the prior or the posterior modal estimates
#'   of the intercept (\eqn{theta1}) and the slope (\eqn{theta2}).
#'   This slot is used in output to display as the mean of the prior or posterior
#'   bivariate normal distribution for \eqn{theta1} and \eqn{theta2}.
#' @slot Q (`matrix`)\cr is the prior or posterior (given that observed, no DLT
#'   data is available) precision matrix. It is specified as
#'   \eqn{Q = X0^T * X0 + X^T * X}, where \eqn{X0} is a design matrix that is
#'   based on pseudo dose levels only, and \eqn{X} is a design matrix that is
#'   based on dose levels corresponding to the observed, no DLT efficacy values
#'   only (if any).
#' @slot const (`number`)\cr a non-negative number (default to 0), leading to the
#'   model form described above. In general, the model has the form
#'   \eqn{y_i = theta1 + theta2 * log(log(x_i + const)) + epsilon_i}, such that
#'   dose levels greater than \eqn{1 - const} can be considered as described in
#'   Yeung et al. (2015).
#'
#' @aliases Effloglog
#' @export
#'
.Effloglog <- setClass(
  Class = "Effloglog",
  slots = c(
    eff = "numeric",
    eff_dose = "numeric",
    nu = "numeric",
    use_fixed = "logical",
    theta1 = "numeric",
    theta2 = "numeric",
    Pcov = "matrix",
    X = "matrix",
    Y = "numeric",
    mu = "numeric",
    Q = "matrix",
    const = "numeric"
  ),
  prototype = prototype(
    eff = c(0, 0),
    eff_dose = c(1, 1),
    nu = 1 / 0.025,
    use_fixed = TRUE,
    const = 0
  ),
  contains = "ModelEff",
  validity = v_model_eff_log_log
)

## constructor ----

#' @rdname Effloglog-class
#'
#' @param eff (`numeric`)\cr the pseudo efficacy responses.
#'   Elements of `eff` must correspond to the elements of `eff_dose`.
#' @param eff_dose (`numeric`)\cr dose levels that correspond to pseudo efficacy
#'   responses in `eff`.
#' @param nu (`numeric`)\cr the precision (inverse of the variance) of the
#'   efficacy responses. This is either a fixed value or a named vector with two
#'   positive numbers, the shape (`a`), and the rate (`b`) parameters for the
#'   gamma distribution.
#' @param data (`DataDual`)\cr observed data to update estimates of the model
#'   parameters.
#' @param const (`number`)\cr the constant value added to the dose level when
#'   the dose level value is less than or equal to 1 and a special form of the
#'   linear log-log has to applied (Yeung et al. (2015).).
#'
#' @export
#' @example examples/Model-class-Effloglog.R
#'
Effloglog <- function(eff,
                      eff_dose,
                      nu,
                      data,
                      const = 0) {
  assert_numeric(eff)
  assert_numeric(eff_dose, len = length(eff))
  assert_numeric(nu, min.len = 1, max.len = 2)
  assert_class(data, "Data")
  assert_number(const, finite = TRUE)

  use_fixed <- length(nu) == 1L

  eff_dose <- eff_dose + const
  # Get observed efficacy data without DLT (if any).
  eff_obsrv_w_x <- getEff(data, no_dlt = TRUE)
  eff_obsrv <- eff_obsrv_w_x$w_no_dlt
  eff_obsrv_dose <- eff_obsrv_w_x$x_no_dlt + const

  # Fit pseudo and observed (if any) efficacy.
  w <- c(eff, eff_obsrv)
  x <- c(eff_dose, eff_obsrv_dose)
  fit_eff <- suppressWarnings(lm(w ~ log(log(x))))
  X <- model.matrix(fit_eff)
  Y <- w
  mu <- coef(fit_eff) # This is [theta1, theta2]^T est.
  Q <- crossprod(X)
  Pcov <- vcov(fit_eff)

  nobs_no_dlt <- length(eff_obsrv)
  if (nobs_no_dlt > 0L) { # Observed data available.
    # Set X, Y to observed data only.
    X <- model.matrix(fit_eff)[-seq_along(eff), ]
    Y <- eff_obsrv

    fit_eff0 <- lm(eff ~ log(log(eff_dose))) # Pseudo only.
    X0 <- model.matrix(fit_eff0)
    mu0 <- coef(fit_eff0)
    Q0 <- crossprod(X0)
    # Note that mu = (Q0 + X^T * X)^{-1} * (Q0 * mu0 + X^T * X * (X^T * X)^{-1} X^T * Y),
    # given that (X^T * X) is invertible and X, Y, mu0, Q0, are specified in this else block.
    if (!use_fixed) {
      nu["a"] <- nu["a"] + (nobs_no_dlt) / 2
      nu["b"] <- nu["b"] + (crossprod(Y) + t(mu0) %*% Q0 %*% mu0 - t(mu) %*% Q %*% mu) / 2
    }
  }

  .Effloglog(
    eff = eff,
    eff_dose = eff_dose,
    nu = nu,
    use_fixed = use_fixed,
    theta1 = mu[["(Intercept)"]],
    theta2 = mu[["log(log(x))"]],
    Pcov = Pcov,
    X = X,
    Y = Y,
    mu = as.vector(mu),
    Q = Q,
    const = const,
    data = data
  )
}

## default constructor ----

#' @rdname Effloglog-class
#' @note Typically, end users will not use the `.DefaultEffloglog()` function.
#' @export
.DefaultEffloglog <- function() {
  emptydata <- DataDual(doseGrid = seq(25, 300, 25), placebo = FALSE)

  my_data <- DataDual(
    x = c(25, 50, 50, 75, 100, 100, 225, 300),
    y = c(0, 0, 0, 0, 1, 1, 1, 1),
    w = c(0.31, 0.42, 0.59, 0.45, 0.6, 0.7, 0.6, 0.52),
    doseGrid = emptydata@doseGrid,
    ID = 1L:8L,
    cohort = as.integer(c(1, 2, 2, 3, 4, 4, 5, 6))
  )

  Effloglog(
    eff = c(1.223, 2.513),
    eff_dose = c(25, 300),
    nu = c(a = 1, b = 0.025),
    data = my_data
  )
}

# EffFlexi ----

## class ----

#' `EffFlexi`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`EffFlexi`] is the class for the efficacy model in flexible form of prior
#' expressed in form of pseudo data. In this class, a flexible form is used to
#' describe the relationship between the efficacy responses and the dose levels
#' and it is specified as
#' \deqn{(W | betaW, sigma2W) ~ Normal(X * betaW, sigma2W * I),}
#' where \eqn{W} is a vector of the efficacy responses, \eqn{betaW} is a column
#' vector of the mean efficacy responses for all dose levels, and \eqn{X} is
#' the design matrix with entries \eqn{I_i,j} that are equal to 1 if subject
#' \eqn{i} is allocated to dose \eqn{j}, and \eqn{0} otherwise. The \eqn{sigma2W}
#' is the variance of the efficacy responses which can be either a fixed number
#' or a number from an inverse gamma distribution.
#' This flexible form aims to capture different shapes of the dose-efficacy
#' curve. In addition, the first (RW1) or second order (RW2) random walk model
#' can be used for smoothing data. That is the random walk model is used to model
#' the first or the second order differences of the mean efficacy responses to
#' its neighboring dose levels of their mean efficacy responses.
#'
#' The RW1 model is given as
#' \deqn{betaW_j - betaW_j-1) ~ Normal(0, sigma2betaW),}
#' and for RW2 as
#' \deqn{betaW_j-2 - 2 * betaW_j-1 + beta_j ~ Normal(0, sigma2betaW),}
#' where \eqn{betaW_j} is the vector of mean efficacy responses at dose j, and
#' the \eqn{sigma2betaW} is the prior variance which can be either a fixed
#' number or a number from an inverse gamma distribution.
#'
#' The `eff` and `eff_dose` are the pseudo efficacy responses and dose levels at
#' which these pseudo efficacy responses are observed. Both, `eff` and `eff_dose`
#' must be vectors of length at least 2. The positions of the elements specified
#' in `eff` and `eff_dose` must correspond to each other between these vectors.
#'
#' @details This model will output the updated value or the updated values of the
#'   parameters of the inverse gamma distributions for \eqn{sigma2W} and
#'   \eqn{sigma2betaW}. The `EffFlexi` inherits all slots from [`ModelEff`] class.
#'
#' @slot eff (`numeric`)\cr the pseudo efficacy responses. Each element here
#'   must represent responses treated based on one subject.
#'   It must be a vector of length at least 2 and the order of its elements must
#'   correspond to values specified in `eff_dose`.
#' @slot eff_dose (`numeric`)\cr the pseudo efficacy dose levels at which the
#'   pseudo efficacy responses are observed.
#'   It must be a vector of length at least 2 and the order of its elements must
#'   correspond to values specified in `eff`.
#' @slot sigma2W (`numeric`)\cr the prior variance of the flexible efficacy form.
#'   This is either a fixed value or a named vector with two positive numbers,
#'   the shape (`a`), and the rate (`b`) parameters for the gamma distribution.
#' @slot sigma2betaW (`numeric`)\cr the prior variance of the random walk model
#'   for the mean efficacy responses. This is either a fixed value or a named
#'   vector with two positive numbers, the shape (`a`), and the rate (`b`)
#'   parameters for the gamma distribution.
#' @slot use_fixed (`logical`)\cr indicates whether a fixed value for
#'   `sigma2W` and `sigma2betaW` (for each parameter separately) is used or not.
#'   This slot is needed for internal purposes and must not be touched by the user.
#' @slot rw1 (`flag`)\cr used for smoothing data for this efficacy model. If it
#'   is `TRUE`, the first-order random walk model is used for the mean efficacy
#'   responses. Otherwise, the random walk of second order is used.
#' @slot X (`matrix`)\cr the design matrix for the efficacy responses. It is
#'   based on both the pseudo and the observed efficacy responses.
#' @slot RW (`matrix`)\cr the difference matrix for the random walk model. This
#'   slot is needed for internal purposes and must not be used by the user.
#' @slot RW_rank (`integer`)\cr is the rank of the difference matrix. This
#'   slot is needed for internal purposes and must not be used by the user.
#'
#' @aliases EffFlexi
#' @export
#'
.EffFlexi <- setClass(
  Class = "EffFlexi",
  slots = c(
    eff = "numeric",
    eff_dose = "numeric",
    sigma2W = "numeric",
    sigma2betaW = "numeric",
    use_fixed = "logical",
    rw1 = "logical",
    X = "matrix",
    RW = "matrix",
    RW_rank = "integer"
  ),
  prototype = prototype(
    eff = c(0, 0),
    eff_dose = c(1, 1),
    sigma2W = 0.025,
    sigma2betaW = 1,
    rw1 = TRUE,
    use_fixed = c(sigma2W = TRUE, sigma2betaW = TRUE)
  ),
  contains = "ModelEff",
  validity = v_model_eff_flexi
)

## constructor ----

#' @rdname EffFlexi-class
#'
#' @param eff (`numeric`)\cr the pseudo efficacy responses.
#'   Elements of `eff` must correspond to the elements of `eff_dose`.
#' @param eff_dose (`numeric`)\cr dose levels that correspond to pseudo efficacy
#'   responses in `eff`.
#' @param sigma2W (`numeric`)\cr the prior variance of the efficacy responses.
#'   This is either a fixed value or a named vector with two positive numbers,
#'   the shape (`a`), and the rate (`b`) parameters for the inverse gamma
#'   distribution.
#' @param sigma2betaW (`numeric`)\cr the prior variance of the random walk model
#'   used for smoothing. This is either a fixed value or a named vector with two
#'   positive numbers, the shape (`a`), and the rate (`b`) parameters for the
#'   inverse gamma distribution.
#' @param rw1 (`flag`)\cr used for smoothing data for this efficacy model. If it
#'   is `TRUE`, the first-order random walk model is used for the mean efficacy
#'   responses. Otherwise, the random walk of second order is used.
#' @param data (`DataDual`)\cr observed data to update estimates of the model
#'   parameters.
#'
#' @export
#' @example examples/Model-class-EffFlexi.R
#'
EffFlexi <- function(eff,
                     eff_dose,
                     sigma2W,
                     sigma2betaW,
                     rw1 = TRUE,
                     data) {
  assert_numeric(eff)
  assert_numeric(eff_dose)
  assert_numeric(sigma2W, min.len = 1, max.len = 2)
  assert_numeric(sigma2betaW, min.len = 1, max.len = 2)
  assert_flag(rw1)
  assert_class(data, "DataDual")

  use_fixed <- c(
    sigma2W = test_number(sigma2W),
    sigma2betaW = test_number(sigma2betaW)
  )

  x <- c(eff_dose, getEff(data, no_dlt = TRUE)$x_no_dlt)
  x_level <- match_within_tolerance(x, data@doseGrid)
  X <- model.matrix(~ -1L + factor(x_level, levels = seq_len(data@nGrid)))
  X <- matrix(as.integer(X), ncol = ncol(X)) # To remove some obsolete attributes.

  # Set up the random walk penalty matrix and its rank.
  # D1: difference matrix of order 1.
  D1 <- cbind(0, diag(data@nGrid - 1)) - cbind(diag(data@nGrid - 1), 0)
  if (rw1) { # the rank-deficient prior precision for the RW1 prior.
    RW <- crossprod(D1)
    RW_rank <- data@nGrid - 1L # rank = dimension - 1. # nolintr
  } else { # Second-order difference.
    D2 <- D1[-1, -1] %*% D1
    RW <- crossprod(D2)
    RW_rank <- data@nGrid - 2L # nolintr
  }

  .EffFlexi(
    eff = eff,
    eff_dose = eff_dose,
    sigma2W = sigma2W,
    sigma2betaW = sigma2betaW,
    use_fixed = use_fixed,
    rw1 = rw1,
    X = X,
    RW = RW,
    RW_rank = RW_rank,
    data = data
  )
}

## default constructor ----

#' @rdname EffFlexi-class
#' @note Typically, end users will not use the `.DefaultEffFlexi()` function.
#' @export
.DefaultEffFlexi <- function() {
  empty_data <- DataDual(doseGrid = seq(25, 300, 25))
  EffFlexi(
    eff = c(1.223, 2.513),
    eff_dose = c(25, 300),
    sigma2W = c(a = 0.1, b = 0.1),
    sigma2betaW = c(a = 20, b = 50),
    rw1 = FALSE,
    data = empty_data
  )

  data <- DataDual(
    x = c(25, 50, 50, 75, 100, 100, 225, 300),
    y = c(0, 0, 0, 0, 1, 1, 1, 1),
    w = c(0.31, 0.42, 0.59, 0.45, 0.6, 0.7, 0.6, 0.52),
    doseGrid = empty_data@doseGrid,
    ID = 1L:8L,
    cohort = as.integer(c(1, 2, 2, 3, 4, 4, 5, 6))
  )

  EffFlexi(
    eff = c(1.223, 2.513),
    eff_dose = c(25, 300),
    sigma2W = c(a = 0.1, b = 0.1),
    sigma2betaW = c(a = 20, b = 50),
    rw1 = FALSE,
    data = data
  )
}

# DALogisticLogNormal ----

## class ----

#' `DALogisticLogNormal`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`DALogisticLogNormal`] is the class for the logistic model with bivariate
#' (log) normal prior and data augmentation. This class inherits from the
#' [`LogisticLogNormal`] class.
#'
#' @note We still need to include here formula for the lambda prior.
#'
#' @slot npiece (`number`)\cr the number of pieces in the `PEM`.
#' @slot l (`numeric`)\cr a vector used in the lambda prior.
#' @slot c_par (`numeric`)\cr a parameter used in the lambda prior; according to
#'   Liu's paper, `c_par = 2` is recommended.
#' @slot cond_pem (`flag`)\cr is a conditional piecewise-exponential model used?
#'   (default). Otherwise an unconditional model is used.
#'
#' @seealso [`ModelLogNormal`], [`LogisticNormal`], [`LogisticLogNormal`].
#'
#' @aliases DALogisticLogNormal
#' @export
#'
.DALogisticLogNormal <- setClass(
  Class = "DALogisticLogNormal",
  slots = c(
    npiece = "integer",
    l = "numeric",
    c_par = "numeric",
    cond_pem = "logical"
  ),
  prototype = prototype(
    npiece = 3L,
    l = 0.5,
    c_par = 2,
    cond_pem = TRUE
  ),
  contains = "LogisticLogNormal",
  validity = v_model_da_logistic_log_normal
)

## constructor ----

#' @rdname DALogisticLogNormal-class
#'
#' @param npiece (`number`)\cr the number of pieces in the `PEM`.
#' @param l (`numeric`)\cr a vector used in the lambda prior.
#' @param c_par (`numeric`)\cr a parameter used in the lambda prior; according to
#'   Liu's paper, `c_par = 2` is recommended.
#' @param cond_pem (`flag`)\cr is a conditional piecewise-exponential model used?
#'   (default). Otherwise an unconditional model is used.
#' @inheritDotParams LogisticLogNormal
#'
#' @export
#' @example examples/Model-class-DALogisticLogNormal.R
#'
DALogisticLogNormal <- function(npiece = 3,
                                l,
                                c_par = 2,
                                cond_pem = TRUE,
                                ...) {
  assert_flag(cond_pem)

  start <- LogisticLogNormal(...)

  datamodel <- function() {
    for (i in 1:nObs) {
      # Part I: describe the logistic model of DLTs vs dose.
      logit(p[i]) <- alpha0 + alpha1 * log(x[i] / ref_dose)

      # Part II: describe the piecewise exponential.
      # Notice that:
      # when y=1             -> DLT=1 and u=<T;
      # when y=0 & T<t (u=T) -> DLT=0;
      # when y=0 & T>t (u<T) -> DLT=NA/missing;
      # when indx=0 -> censored, i.e u<T and event=0;
      # when indx=1 -> not censored, i.e. u>=T or event=1;
      indx[i] <- 1 - step(Tmax - u[i] - eps) * (1 - y[i])

      for  (j in 1:npiece) {
        # When not censored, i.e DLT!=NA & t[i]=u[i];
        # if t[i]<h[j], d[i,j]=0;
        # if h[j]<t[i]=<h[j+1], d[i,j]=1
        # if h[j+1]<t[i], d[i,j]=0
        # When censored t[i]>u[i] -> d[i,j]=0
        d[i, j] <- y[i] * step(u[i] - h[j] - eps) * step(h[j + 1] - u[i])

        # DLT free survival(time) for patient i in interval I(j);
        # if t[i]<h[j], s[i,j]=0;
        # if h[j]<t[i]<=h[j+1], s[i,j]=t[i]-h[j]
        # if h[j+1]<=t[i], s[i,j]=h[j+1]-h[j]
        s[i, j] <- min(u[i] - h[j], h[j + 1] - h[j]) * step(u[i] - h[j])

        # piecewise exponential hazard rate lambda[j];
        mu_u[i, j] <- lambda[j] * s[i, j]
        mu[i, j] <- d[i, j] * log(lambda[j]) - y[i] * mu_u[i, j]
      }

      # The likelihood function.
      L_obs[i] <- exp(sum(mu[i, ])) * pow(p[i] / A, y[i]) * pow(1 - p[i], 1 - y[i]) # Not censored. # nolintr
      L_cnsr[i] <- 1 - p[i] * (1 - exp(-sum(mu_u[i, ]))) / A # Censored. # nolintr
      L[i] <- pow(L_obs[i], indx[i]) * pow(L_cnsr[i], 1 - indx[i])

      # Apply zero trick in JAGS.
      phi[i] <- -log(L[i]) + cadj
      zeros[i] ~ dpois(phi[i])
    }
  }

  priormodel <- h_jags_join_models(
    start@priormodel,
    function() {
      g_beta <- 1 / c_par
      for  (j in 1:npiece) {
        g_alpha[j] <- l[j] / c_par
        lambda[j] ~ dgamma(g_alpha[j], g_beta)
        mu_T[j] <- lambda[j] * (h[j + 1] - h[j]) # nolintr
      }
      # If cond = 1, then conditional PEM is used and A is defined as
      # the probability to have DLT, i.e. t<T, otherwise
      # cond = 0 and A is just 1 (so no impact in likelihood).
      A <- cond * (1 - exp(-sum(mu_T))) + (1 - cond)
    }
  )

  modelspecs <- function(nObs, Tmax, from_prior) {
    ms <- list(
      prec = start@params@prec,
      mean = start@params@mean,
      npiece = npiece,
      l = l,
      c_par = c_par,
      h = seq(from = 0L, to = Tmax, length = npiece + 1),
      cond = as.integer(cond_pem)
    )
    if (!from_prior) {
      ms <- c(list(ref_dose = start@ref_dose, zeros = rep(0, nObs), eps = 1e-10, cadj = 1e10), ms)
    }
    ms
  }

  assert_integerish(npiece, lower = 1)

  .DALogisticLogNormal(
    start,
    npiece = as.integer(npiece),
    l = l,
    c_par = c_par,
    cond_pem = cond_pem,
    datamodel = datamodel,
    priormodel = priormodel,
    modelspecs = modelspecs,
    datanames = c("nObs", "y", "x", "u", "Tmax"),
    sample = c("alpha0", "alpha1", "lambda")
  )
}

## default constructor ----

#' @rdname DALogisticLogNormal-class
#' @note Typically, end users will not use the `.DefaultDALogisticLogNormal()` function.
#' @export
.DefaultDALogisticLogNormal <- function() {
  npiece <- 10
  Tmax <- 60

  lambda_prior <- function(k) {
    npiece / (Tmax * (npiece - k + 0.5))
  }

  DALogisticLogNormal(
    mean = c(-0.85, 1),
    cov = matrix(c(1, -0.5, -0.5, 1), nrow = 2),
    ref_dose = 56,
    npiece = npiece,
    l = as.numeric(t(apply(as.matrix(c(1:npiece), 1, npiece), 2, lambda_prior))),
    c_par = 2
  )
}

# TITELogisticLogNormal ----

## class ----

#' `TITELogisticLogNormal`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`TITELogisticLogNormal`] is the class for TITE-CRM based on a logistic
#' regression model using a bivariate normal prior on the intercept and log
#' slope parameters.
#'
#' This class inherits from the [`LogisticLogNormal`].
#'
#' @slot weight_method (`string`)\cr the weight function method: either linear
#'   or adaptive. This was used in Liu, Yin and Yuan's paper.
#'
#' @seealso [`DALogisticLogNormal`].
#'
#' @aliases TITELogisticLogNormal
#' @export
#'
.TITELogisticLogNormal <- setClass(
  Class = "TITELogisticLogNormal",
  slots = c(weight_method = "character"),
  prototype = prototype(weight_method = "linear"),
  contains = "LogisticLogNormal",
  validity = v_model_tite_logistic_log_normal
)

## constructor ----

#' @rdname TITELogisticLogNormal-class
#'
#' @param weight_method (`string`)\cr the weight function method: either linear
#'   or adaptive. This was used in Liu, Yin and Yuan's paper.
#' @inheritDotParams LogisticLogNormal
#'
#' @export
#' @example examples/Model-class-TITELogisticLogNormal.R
#'
TITELogisticLogNormal <- function(weight_method = "linear",
                                  ...) {
  assert_character(weight_method, min.len = 1L, max.len = 2L, any.missing = FALSE)

  start <- LogisticLogNormal(...)

  datamodel <- function() {
    for (i in 1:nObs) {
      logit(p[i]) <- alpha0 + alpha1 * log(x[i] / ref_dose)

      # The piecewise exponential likelihood. Notice that:
      # when y=1             -> DLT=1 and u=<T;
      # when y=0 & T<t (u=T) -> DLT=0;
      # when y=0 & T>t (u<T) -> DLT=NA/missing;
      # when indx=0 -> censored, i.e u<T and event=0;
      # when indx=1 -> not censored, i.e. u>=T or event=1;
      L[i] <- pow(p[i], y[i]) * pow((1 - w[i] * p[i]), (1 - y[i]))

      # Apply zero trick in JAGS.
      phi[i] <- -log(L[i]) + cadj
      zeros[i] ~ dpois(phi[i])
    }
  }

  modelspecs <- function(nObs, u, Tmax, y, from_prior) {
    ms <- list(prec = start@params@prec, mean = start@params@mean)
    # Calculate weights `w` based on the input data.
    if (!from_prior && nObs > 0L) {
      if (weight_method == "linear") {
        w <- u / Tmax
      } else if (weight_method == "adaptive") {
        nDLT <- sum(y)
        if (nDLT > 0) {
          u_dlt <- sort(u[y == 1])
          w <- sapply(u, function(u_i) {
            m <- sum(u_i >= u_dlt)
            w_i <- if (m == 0) {
              u_i / u_dlt[1]
            } else if (m < nDLT) {
              m + (u_i - u_dlt[m]) / (u_dlt[m + 1] - u_dlt[m])
            } else { # m == nDLT. nolintr
              m + (u_i - u_dlt[m]) / (Tmax + 0.00000001 - u_dlt[m])
            }
            w_i / (nDLT + 1)
          })
        } else {
          w <- u / Tmax
        }
      }
      w[y == 1] <- 1
      w[u == Tmax] <- 1

      ms <- c(list(ref_dose = start@ref_dose, zeros = rep(0, nObs), cadj = 1e10, w = w), ms)
    }
    ms
  }

  .TITELogisticLogNormal(
    start,
    weight_method = weight_method,
    datamodel = datamodel,
    modelspecs = modelspecs,
    datanames = c("nObs", "y", "x")
  )
}

## default constructor ----

#' @rdname TITELogisticLogNormal-class
#' @note Typically, end users will not use the `.DefaultTITELogisticLogNormal()` function.
#' @export
.DefaultTITELogisticLogNormal <- function() {
  TITELogisticLogNormal(
    mean = c(0, 1),
    cov = diag(2),
    ref_dose = 1,
    weight_method = "linear"
  )
}

# OneParLogNormalPrior ----

## class ----

#' `OneParLogNormalPrior`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`OneParLogNormalPrior`] is the class for a standard CRM with a normal prior on
#' the log power parameter for the skeleton prior probabilities.
#'
#' @slot skel_fun (`function`)\cr function to calculate the prior DLT probabilities.
#' @slot skel_fun_inv (`function`)\cr inverse function of `skel_fun`.
#' @slot skel_probs (`numeric`)\cr skeleton prior probabilities. This is a vector
#'   of unique and sorted probability values between 0 and 1.
#' @slot sigma2 (`number`)\cr prior variance of log power parameter alpha.
#'
#' @seealso [`ModelLogNormal`].
#'
#' @aliases OneParLogNormalPrior
#' @export
#'
.OneParLogNormalPrior <- setClass(
  Class = "OneParLogNormalPrior",
  slots = c(
    skel_fun = "function",
    skel_fun_inv = "function",
    skel_probs = "numeric",
    sigma2 = "numeric"
  ),
  contains = "GeneralModel",
  validity = v_model_one_par_exp_normal_prior
)

## constructor ----

#' @rdname OneParLogNormalPrior-class
#'
#' @param skel_probs (`numeric`)\cr skeleton prior probabilities. This is a vector
#'   of unique and sorted probability values between 0 and 1.
#' @param dose_grid (`numeric`)\cr dose grid. It must be must be a sorted vector
#'   of the same length as `skel_probs`.
#' @param sigma2 (`number`)\cr prior variance of log power parameter alpha.
#'
#' @export
#' @example examples/Model-class-OneParLogNormalPrior.R
#'
OneParLogNormalPrior <- function(skel_probs,
                                 dose_grid,
                                 sigma2) {
  assert_probabilities(skel_probs, unique = TRUE, sorted = TRUE) # So that skel_fun_inv exists.
  assert_numeric(dose_grid, len = length(skel_probs), any.missing = FALSE, unique = TRUE, sorted = TRUE)

  skel_fun <- approxfun(x = dose_grid, y = skel_probs, rule = 2)
  skel_fun_inv <- approxfun(x = skel_probs, y = dose_grid, rule = 2)

  .OneParLogNormalPrior(
    skel_fun = skel_fun,
    skel_fun_inv = skel_fun_inv,
    skel_probs = skel_probs,
    sigma2 = sigma2,
    datamodel = function() {
      for (i in 1:nObs) {
        p[i] <- skel_probs[xLevel[i]]^exp(alpha)
        y[i] ~ dbern(p[i])
      }
    },
    priormodel = function() {
      alpha ~ dnorm(0, 1 / sigma2)
    },
    modelspecs = function(from_prior) {
      ms <- list(sigma2 = sigma2)
      if (!from_prior) {
        ms$skel_probs <- skel_probs
      }
      ms
    },
    init = function() {
      list(alpha = 1)
    },
    datanames = c("nObs", "y", "xLevel"),
    sample = "alpha"
  )
}

## default constructor ----

#' @rdname OneParLogNormalPrior-class
#' @return an instance of the `OneParLogNormalPrior` class
#' @export
.DefaultOneParLogNormalPrior <- function() {
  OneParLogNormalPrior(
    skel_probs = seq(from = 0.1, to = 0.9, length = 5),
    dose_grid = 1:5,
    sigma2 = 2
  )
}

# OneParExpPrior ----

## class ----

#' `OneParExpPrior`
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' [`OneParExpPrior`] is the class for a standard CRM with an exponential prior
#' on the power parameter for the skeleton prior probabilities. It is an
#' implementation of a version of the one-parameter CRM (O’Quigley et al. 1990).
#'
#' @note Typically, end users will not use the `.DefaultOneparExpPrior()` function.
#'
#' @slot skel_fun (`function`)\cr function to calculate the prior DLT probabilities.
#' @slot skel_fun_inv (`function`)\cr inverse function of `skel_fun`.
#' @slot skel_probs (`numeric`)\cr skeleton prior probabilities. This is a vector
#'   of unique and sorted probability values between 0 and 1.
#' @slot lambda (`number`)\cr rate parameter of prior exponential distribution
#'   for theta.
#'
#' @aliases OneParExpPrior
#' @export
#'
.OneParExpPrior <- setClass(
  Class = "OneParExpPrior",
  slots = c(
    skel_fun = "function",
    skel_fun_inv = "function",
    skel_probs = "numeric",
    lambda = "numeric"
  ),
  contains = "GeneralModel",
  validity = v_model_one_par_exp_prior
)

## constructor ----

#' @rdname OneParExpPrior-class
#'
#' @param skel_probs see slot definition.
#' @param dose_grid (`numeric`)\cr dose grid. It must be must be a sorted vector
#'   of the same length as `skel_probs`.
#' @param lambda see slot definition.
#'
#' @export
#' @example examples/Model-class-OneParExpPrior.R
#'
OneParExpPrior <- function(skel_probs,
                           dose_grid,
                           lambda) {
  assert_probabilities(skel_probs, unique = TRUE, sorted = TRUE) # So that skel_fun_inv exists.
  assert_numeric(dose_grid, len = length(skel_probs), any.missing = FALSE, unique = TRUE, sorted = TRUE)

  skel_fun <- approxfun(x = dose_grid, y = skel_probs, rule = 2)
  skel_fun_inv <- approxfun(x = skel_probs, y = dose_grid, rule = 2)

  .OneParExpPrior(
    skel_fun = skel_fun,
    skel_fun_inv = skel_fun_inv,
    skel_probs = skel_probs,
    lambda = lambda,
    datamodel = function() {
      for (i in 1:nObs) {
        p[i] <- skel_probs[xLevel[i]]^theta
        y[i] ~ dbern(p[i])
      }
    },
    priormodel = function() {
      theta ~ dexp(lambda)
    },
    modelspecs = function(from_prior) {
      ms <- list(lambda = lambda)
      if (!from_prior) {
        ms$skel_probs <- skel_probs
      }
      ms
    },
    init = function() {
      list(theta = 1)
    },
    datanames = c("nObs", "y", "xLevel"),
    sample = "theta"
  )
}

## default constructor ----

#' @rdname OneParExpPrior-class
#' @note Typically, end users will not use the `.DefaultOneParLogNormalPrior()` function.
#' @export
.DefaultOneParExpPrior <- function() {
  OneParExpPrior(
    skel_probs = c(0.1, 0.3, 0.5, 0.7, 0.9),
    dose_grid = 1:5,
    lambda = 2
  )
}

# FractionalCRM ----

## class ----

#' `FractionalCRM`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`FractionalCRM`] is the class for a fractional CRM model based on a one
#' parameter CRM (with normal prior on the log-power parameter) as well as
#' Kaplan-Meier based estimation of the conditional probability to experience a
#' DLT for non-complete observations.
#'
#' This fractional CRM model follows the paper and code by Guosheng Yin et al.
#'
#' @seealso [`TITELogisticLogNormal`].
#'
#' @aliases FractionalCRM
#' @export
#'
.FractionalCRM <- setClass(
  Class = "FractionalCRM",
  contains = "OneParLogNormalPrior"
)

## constructor ----

#' @rdname FractionalCRM-class
#'
#' @inheritDotParams OneParLogNormalPrior
#'
#' @export
#' @example examples/Model-class-FractionalCRM.R
#'
FractionalCRM <- function(...) {
  start <- OneParLogNormalPrior(...)

  # This is adapted from the TITELogisticLogNormal class.
  datamodel <- function() {
    for (i in 1:nObs) {
      p[i] <- skel_probs[xLevel[i]]^exp(alpha)

      # The piecewise exponential likelihood. Notice that:
      # when y=1             -> DLT=1 and u=<T;
      # when y=0 & T<t (u=T) -> DLT=0;
      # when y=0 & T>t (u<T) -> DLT=NA/missing.
      # Therefore, `yhat` is used instead of `y` for the likelihood f. (see `modelspecs`).
      L[i] <- pow(p[i], yhat[i]) * pow((1 - p[i]), (1 - yhat[i]))

      # Apply zero trick in JAGS.
      phi[i] <- -log(L[i]) + cadj
      zeros[i] ~ dpois(phi[i])
    }
  }

  modelspecs <- function(nObs, u, Tmax, y, from_prior) {
    ms <- list(sigma2 = start@sigma2)
    if (!from_prior) {
      # Calculate fractional contribution `yhat`
      # based on the input data using the Kaplan-Meier method.
      yhat <- if (nObs > 0) {
        km <- survival::survfit(survival::Surv(u, y) ~ 1)
        s_tau <- tail(km$surv[km$time <= Tmax], 1) # Survival probability = S(Tmax).
        ifelse(
          u < Tmax & y == 0L, # Within the assessment window and so far no DLT.
          yes = 1 - s_tau / sapply(u, function(u_i) tail(km$surv[km$time <= u_i], 1)),
          no = y
        )
      } else {
        1L
      }
      ms <- c(
        list(skel_probs = start@skel_probs, zeros = rep(0, nObs), cadj = 1e10, yhat = yhat),
        ms
      )
    }
    ms
  }

  .FractionalCRM(
    start,
    datamodel = datamodel,
    modelspecs = modelspecs,
    datanames = c("nObs", "xLevel")
  )
}

## default constructor ----

#' @rdname FractionalCRM-class
#' @note Typically, end users will not use the `.DefaultTITELogisticLogNormal()` function.
#' @export
.DefaultFractionalCRM <- function() {
  FractionalCRM(
    skel_probs = c(0.1, 0.2, 0.3, 0.4),
    dose_grid = c(10, 30, 50, 100),
    sigma2 = 2
  )
}

## class ----

#' `LogisticLogNormalOrdinal`
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' [`LogisticLogNormalOrdinal`] is the class for a logistic lognormal CRM model
#' using an ordinal toxicity scale.
#'
#' @aliases LogisticLogNormalOrdinal
#' @export
.LogisticLogNormalOrdinal <- setClass(
  Class = "LogisticLogNormalOrdinal",
  contains = "ModelLogNormal",
  validity = v_logisticlognormalordinal
)

## constructor ----

#' @rdname LogisticLogNormalOrdinal-class
#' @inheritParams ModelLogNormal
#' @export
#' @example examples/Model-class-LogisticLogNormalOrdinal.R
LogisticLogNormalOrdinal <- function(mean, cov, ref_dose) {
  params <- ModelParamsNormal(mean, cov)
  .LogisticLogNormalOrdinal(
    params = params,
    ref_dose = positive_number(ref_dose),
    priormodel = function() {
      alpha[1] ~ dnorm(mean[1], prec[1, 1])
      for (i in 2:(k - 1)) {
        alpha[i] ~ dnorm(mean[i], prec[i, i]) %_% T(, alpha[i - 1])
      }
      gamma ~ dnorm(mean[k], prec[k, k])
      beta <- exp(gamma)
    },
    datamodel = function() {
      for (i in 1:nObs) {
        xhat[i] <- log(x[i] / ref_dose)
        for (j in 1:(k - 1)) {
          z[i, j] <- alpha[j] + beta * xhat[i]
          p[i, j] <- exp(z[i, j]) / (1 + exp(z[i, j]))
          tox[i, j] ~ dbern(p[i, j])
        }
      }
    },
    modelspecs = function(y, from_prior) {
      ms <- list(
        mean = params@mean,
        prec = params@prec,
        k = length(mean),
        tox = array(dim = c(length(y), length(mean) - 1))
      )
      if (!from_prior) {
        for (i in seq_along(y)) {
          for (j in 1:(ms$k - 1)) {
            ms$tox[i, j] <- y[i] >= j
          }
        }
        ms$ref_dose <- ref_dose
      }
      ms
    },
    init = function() {
      list(alpha = sapply(1:(length(mean) - 1), function(x) -(x + 1)), gamma = 1)
    },
    datanames = c("nObs", "y", "x"),
    # Need to provide JAGS column names here
    sample = c(paste0("alpha[", 1:(length(mean) - 1), "]"), "beta")
  )
}

## default constructor ----

#' @rdname LogisticLogNormalOrdinal-class
#' @note Typically, end users will not use the `.DefaultLogisticLogNormalOrdinal()` function.
#' @export
.DefaultLogisticLogNormalOrdinal <- function() {
  LogisticLogNormalOrdinal(
    mean = c(-3, -4, 1),
    cov = diag(c(3, 4, 1)),
    ref_dose = 50
  )
}

#' @include Model-class.R
#' @include Samples-class.R
NULL

# doseFunction ----

## generic ----

#' Getting the Dose Function for a Given Model Type
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' A function that returns a [dose()] method that computes the dose reaching a
#' specific target value of a given independent variable, based on the model
#' specific parameters.
#'
#' @param model (`GeneralModel` or `ModelPseudo`)\cr the model.
#' @param ... model specific parameters.
#'
#' @return A [dose()] method that computes doses.
#'
#' @seealso [dose()], [probFunction()].
#'
#' @export
#' @example examples/Model-method-doseFunction.R
#'
setGeneric(
  name = "doseFunction",
  def = function(model, ...) {
    standardGeneric("doseFunction")
  },
  valueClass = "function"
)

## GeneralModel ----

#' @describeIn doseFunction
#'
#' @aliases doseFunction-GeneralModel
#' @export
#'
setMethod(
  f = "doseFunction",
  signature = "GeneralModel",
  definition = function(model, ...) {
    model_params <- list(...)
    assert_subset(names(model_params), model@sample, empty.ok = FALSE)

    samples <- Samples(
      data = model_params,
      options = McmcOptions(samples = NROW(model_params[[1]]))
    )
    function(x, ...) {
      dose(x = x, model = model, samples = samples, ...)
    }
  }
)

## ModelPseudo ----

#' @describeIn doseFunction
#'
#' @aliases doseFunction-ModelPseudo
#' @export
#'
setMethod(
  f = "doseFunction",
  signature = "ModelPseudo",
  definition = function(model, ...) {
    model_params <- list(...)
    assert_character(names(model_params), len = length(model_params), any.missing = FALSE, unique = TRUE)

    samples <- Samples(
      data = model_params,
      options = McmcOptions(samples = length(model_params[[1]]))
    )
    function(x) {
      dose(x = x, model = model, samples = samples)
    }
  }
)

## LogisticLogNormalOrdinal ----

#' @describeIn doseFunction
#'
#' @param grade (`integer`)\cr the toxicity grade for which the dose function is
#' required
#'
#' @aliases doseFunction-LogisticLogNormalOrdinal
#' @example examples/Model-method-doseFunctionLogisticLogNormalOrdinal.R
#' @export
setMethod(
  f = "doseFunction",
  signature = "LogisticLogNormalOrdinal",
  definition = function(model, grade, ...) {
    model_params <- list(...)
    assert_character(
      names(model_params),
      len = length(model_params),
      any.missing = FALSE,
      unique = TRUE
    )
    assert_integer(grade, lower = 1, len = 1)
    coll <- makeAssertCollection()
    if (!(paste0("alpha", grade) %in% names(model_params))) {
      coll$push(
        paste0(
          "Since grade = ", grade, ", a parameter named 'alpha", grade,
          "' must appear the call"
        )
      )
    }
    reportAssertions(coll)
    # Create dummy intercept columns if necessary
    for (g in seq_along(grade)) {
      if (!(paste0("alpha", g) %in% names(model_params))) {
        model_params[[paste0("alpha", g)]] <- rep(0, length(model_params[[1]]))
      }
    }

    samples <- Samples(
      data = model_params,
      options = McmcOptions(samples = length(model_params[[1]]))
    )
    function(x) {
      dose(x = x, model = model, samples = samples, grade = grade)
    }
  }
)

# probFunction ----

## generic ----

#' Getting the Prob Function for a Given Model Type
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' A function that returns a [prob()] function that computes the toxicity
#' probabilities for a given dose level, based on the model specific parameters.
#'
#' @param model (`GeneralModel` or `ModelTox`)\cr the model.
#' @param ... model specific parameters.
#'
#' @return A [prob()] function that computes toxicity probabilities.
#'
#' @seealso [prob()], [doseFunction()].
#'
#' @export
#' @example examples/Model-method-probFunction.R
#'
setGeneric(
  name = "probFunction",
  def = function(model, ...) {
    standardGeneric("probFunction")
  },
  valueClass = "function"
)

## GeneralModel ----

#' @describeIn probFunction
#'
#' @aliases probFunction-GeneralModel
#' @export
#'
setMethod(
  f = "probFunction",
  signature = "GeneralModel",
  definition = function(model, ...) {
    model_params <- list(...)
    assert_subset(names(model_params), model@sample, empty.ok = FALSE)

    samples <- Samples(
      data = model_params,
      options = McmcOptions(samples = NROW(model_params[[1]]))
    )
    function(dose, ...) {
      prob(dose = dose, model = model, samples = samples, ...)
    }
  }
)

## ModelTox ----

#' @describeIn probFunction
#'
#' @aliases probFunction-ModelTox
#' @export
#'
setMethod(
  f = "probFunction",
  signature = "ModelTox",
  definition = function(model, ...) {
    model_params <- list(...)
    assert_character(names(model_params), len = length(model_params), any.missing = FALSE, unique = TRUE)

    samples <- Samples(
      data = model_params,
      options = McmcOptions(samples = length(model_params[[1]]))
    )
    function(dose) {
      prob(dose = dose, model = model, samples = samples)
    }
  }
)

## LogisticLogNormalOrdinal ----

#' @describeIn probFunction
#'
#' @param grade (`integer`)\cr the toxicity grade for which the dose function is
#' required
#'
#' @aliases probFunction-LogisticLogNormalOrdinal
#' @example examples/Model-method-probFunctionLogisticLogNormalOrdinal.R
#' @export
setMethod(
  f = "probFunction",
  signature = "LogisticLogNormalOrdinal",
  definition = function(model, grade, ...) {
    model_params <- list(...)
    assert_character(
      names(model_params),
      len = length(model_params),
      any.missing = FALSE,
      unique = TRUE
    )
    assert_integer(grade, lower = 1, len = 1)
    coll <- makeAssertCollection()
    if (!(paste0("alpha", grade) %in% names(model_params))) {
      coll$push(
        paste0(
          "Since grade = ", grade, ", a parameter named 'alpha", grade,
          "' must appear the call"
        )
      )
    }
    reportAssertions(coll)
    # Create dummy intercept columns if necessary
    for (g in seq_along(grade)) {
      if (!(paste0("alpha", g) %in% names(model_params))) {
        model_params[[paste0("alpha", g)]] <- rep(0, length(model_params[[1]]))
      }
    }

    samples <- Samples(
      data = model_params,
      options = McmcOptions(samples = length(model_params[[1]]))
    )
    function(dose) {
      prob(dose = dose, model = model, samples = samples, grade = grade)
    }
  }
)


# efficacyFunction ----

## generic ----

#' Getting the Efficacy Function for a Given Model Type
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' A function that returns an [efficacy()] function that computes expected
#' efficacy for a given dose level, based on the model specific parameters.
#'
#' @param model (`ModelEff`)\cr the model.
#' @param ... model specific parameters.
#'
#' @return A [efficacy()] function that computes expected efficacy.
#'
#' @seealso [efficacy()].
#'
#' @export
#' @example examples/Model-method-efficacyFunction.R
#'
setGeneric(
  name = "efficacyFunction",
  def = function(model, ...) {
    standardGeneric("efficacyFunction")
  },
  valueClass = "function"
)

## ModelEff ----

#' @describeIn efficacyFunction
#'
#' @aliases efficacyFunction-ModelEff
#' @export
#'
setMethod(
  f = "efficacyFunction",
  signature = "ModelEff",
  definition = function(model, ...) {
    model_params <- list(...)
    assert_character(names(model_params), len = length(model_params), any.missing = FALSE, unique = TRUE)

    samples <- Samples(
      data = model_params,
      options = McmcOptions(samples = NROW(model_params[[1]]))
    )
    function(dose) {
      efficacy(dose = dose, model = model, samples = samples)
    }
  }
)

# dose ----

## generic ----

#' Computing the Doses for a given independent variable, Model and Samples
#'
#' @description `r lifecycle::badge("stable")`
#'
#' A function that computes the dose reaching a specific target value of a
#' given variable that dose depends on. The meaning of this variable depends
#' on the type of the model. For instance, for single agent dose escalation
#' model or pseudo DLE (dose-limiting events)/toxicity model, this variable
#' represents the a probability of the occurrence of a DLE. For efficacy models,
#' it represents expected efficacy.
#' The doses are computed based on the samples of the model parameters (samples).
#'
#' @details The `dose()` function computes the doses corresponding to a value of
#'   a given independent variable, using samples of the model parameter(s).
#'   If you work with multivariate model parameters, then assume that your model
#'   specific `dose()` method receives a samples matrix where the rows
#'   correspond to the sampling index, i.e. the layout is then
#'   `nSamples x dimParameter`.
#'
#' @note The [dose()] and [prob()] methods are the inverse of each other, for
#'   all [dose()] methods for which its first argument, i.e. a given independent
#'   variable that dose depends on, represents toxicity probability.
#'
#' @param x (`proportion` or `numeric`)\cr a value of an independent variable
#'   on which dose depends.
#'   The following recycling rule applies when `samples` is not missing: vectors
#'   of size 1 will be recycled to the size of the sample
#'   (i.e. `size(samples)`). Otherwise, `x` must have the same size
#'   as the sample.
#' @param model (`GeneralModel` or `ModelPseudo`)\cr the model.
#' @param samples (`Samples`)\cr the samples of model's parameters that will be
#'   used to compute the resulting doses. Can also be missing for some models.
#' @param ... model specific parameters when `samples` are not used.
#'
#' @return A `number` or `numeric` vector with the doses.
#'   If non-scalar `samples` were used, then every element in the returned vector
#'   corresponds to one element of a sample. Hence, in this case, the output
#'   vector is of the same length as the sample vector. If scalar `samples` were
#'   used or no `samples` were used, e.g. for pseudo DLE/toxicity `model`,
#'   then the output is of the same length as the length of the `prob`.
#'
#' @seealso [doseFunction()], [prob()], [efficacy()].
#'
#' @export
#' @example examples/Model-method-dose.R
#'
setGeneric(
  name = "dose",
  def = function(x, model, samples, ...) {
    standardGeneric("dose")
  },
  valueClass = "numeric"
)

## LogisticNormal ----

#' @describeIn dose compute the dose level reaching a specific target
#'   probability of the occurrence of a DLE (`x`).
#'
#' @aliases dose-LogisticNormal
#' @export
#'
setMethod(
  f = "dose",
  signature = signature(
    x = "numeric",
    model = "LogisticNormal",
    samples = "Samples"
  ),
  definition = function(x, model, samples) {
    assert_probabilities(x)
    assert_subset(c("alpha0", "alpha1"), names(samples))
    assert_length(x, len = size(samples))

    alpha0 <- samples@data$alpha0
    alpha1 <- samples@data$alpha1
    ref_dose <- as.numeric(model@ref_dose)
    exp((logit(x) - alpha0) / alpha1) * ref_dose
  }
)

## LogisticLogNormal ----

#' @describeIn dose compute the dose level reaching a specific target
#'   probability of the occurrence of a DLE (`x`).
#'
#' @aliases dose-LogisticLogNormal
#' @export
#'
setMethod(
  f = "dose",
  signature = signature(
    x = "numeric",
    model = "LogisticLogNormal",
    samples = "Samples"
  ),
  definition = function(x, model, samples) {
    assert_probabilities(x)
    assert_subset(c("alpha0", "alpha1"), names(samples))
    assert_length(x, len = size(samples))

    alpha0 <- samples@data$alpha0
    alpha1 <- samples@data$alpha1
    ref_dose <- as.numeric(model@ref_dose)
    exp((logit(x) - alpha0) / alpha1) * ref_dose
  }
)

## LogisticLogNormalOrdinal ----

#' @describeIn dose compute the dose level reaching a specific target
#'   probability of the occurrence of a DLE (`x`).
#'
#' In the case of a `LogisticLogNormalOrdinal` model, `dose` returns only the
#' probability of toxicity at the given grade or higher
#'
#' @param grade (`integer`)\cr The toxicity grade for which probabilities are required
#'
#' @aliases dose-LogisticLogNormalOrdinal
#' @example examples/Model-method-doseLogisticLogNormalOrdinal.R
#' @export
#'
setMethod(
  f = "dose",
  signature = signature(
    x = "numeric",
    model = "LogisticLogNormalOrdinal",
    samples = "Samples"
  ),
  definition = function(x, model, samples, grade) {
    assert_probabilities(x)
    assert_length(x, len = size(samples))
    assert_integer(grade, len = 1, lower = 1, upper = (length(names(samples@data)) - 1))
    a <- paste0("alpha", grade)
    assert_subset(c(a, "beta"), names(samples))

    alpha <- samples@data[[a]]
    beta <- samples@data$beta
    ref_dose <- as.numeric(model@ref_dose)
    exp((logit(x) - alpha) / beta) * ref_dose
  }
)

## LogisticLogNormalSub ----

#' @describeIn dose compute the dose level reaching a specific target
#'   probability of the occurrence of a DLE (`x`).
#'
#' @aliases dose-LogisticLogNormalSub
#' @export
#'
setMethod(
  f = "dose",
  signature = signature(
    x = "numeric",
    model = "LogisticLogNormalSub",
    samples = "Samples"
  ),
  definition = function(x, model, samples) {
    assert_probabilities(x)
    assert_subset(c("alpha0", "alpha1"), names(samples))
    assert_length(x, len = size(samples))

    alpha0 <- samples@data$alpha0
    alpha1 <- samples@data$alpha1
    ref_dose <- model@ref_dose
    ((logit(x) - alpha0) / alpha1) + ref_dose
  }
)

## ProbitLogNormal ----

#' @describeIn dose compute the dose level reaching a specific target
#'   probability of the occurrence of a DLE (`x`).
#'
#' @aliases dose-ProbitLogNormal
#' @export
#'
setMethod(
  f = "dose",
  signature = signature(
    x = "numeric",
    model = "ProbitLogNormal",
    samples = "Samples"
  ),
  definition = function(x, model, samples) {
    assert_probabilities(x)
    assert_subset(c("alpha0", "alpha1"), names(samples))
    assert_length(x, len = size(samples))

    alpha0 <- samples@data$alpha0
    alpha1 <- samples@data$alpha1
    ref_dose <- as.numeric(model@ref_dose)
    exp((probit(x) - alpha0) / alpha1) * ref_dose
  }
)

## ProbitLogNormalRel ----

#' @describeIn dose compute the dose level reaching a specific target
#'   probability of the occurrence of a DLE (`x`).
#'
#' @aliases dose-ProbitLogNormalRel
#' @export
#'
setMethod(
  f = "dose",
  signature = signature(
    x = "numeric",
    model = "ProbitLogNormalRel",
    samples = "Samples"
  ),
  definition = function(x, model, samples) {
    assert_probabilities(x)
    assert_subset(c("alpha0", "alpha1"), names(samples))
    assert_length(x, len = size(samples))

    alpha0 <- samples@data$alpha0
    alpha1 <- samples@data$alpha1
    ref_dose <- as.numeric(model@ref_dose)
    ((probit(x) - alpha0) / alpha1) * ref_dose
  }
)

## LogisticLogNormalGrouped ----

#' @describeIn dose method for [`LogisticLogNormalGrouped`] which needs `group`
#'   argument in addition.
#' @param group (`character` or `factor`)\cr for [`LogisticLogNormalGrouped`],
#'   indicating whether to calculate the dose for the `mono` or for
#'   the `combo` arm.
#' @aliases dose-LogisticLogNormalGrouped
#' @export
#'
setMethod(
  f = "dose",
  signature = signature(
    x = "numeric",
    model = "LogisticLogNormalGrouped",
    samples = "Samples"
  ),
  definition = function(x, model, samples, group) {
    assert_probabilities(x)
    assert_subset(c("alpha0", "delta0", "alpha1", "delta1"), names(samples))
    assert_length(x, len = size(samples))
    assert_multi_class(group, c("character", "factor"))
    assert_subset(as.character(group), choices = c("mono", "combo"))
    assert_length(group, len = size(samples))

    alpha0 <- samples@data$alpha0
    delta0 <- samples@data$delta0
    alpha1 <- samples@data$alpha1
    delta1 <- samples@data$delta1
    ref_dose <- as.numeric(model@ref_dose)
    is_combo <- as.integer(group == "combo")
    exp((logit(x) - (alpha0 + is_combo * delta0)) / (alpha1 + is_combo * delta1)) * ref_dose
  }
)

## LogisticKadane ----

#' @describeIn dose compute the dose level reaching a specific target
#'   probability of the occurrence of a DLE (`x`).
#'
#' @aliases dose-LogisticKadane
#' @export
#'
setMethod(
  f = "dose",
  signature = signature(
    x = "numeric",
    model = "LogisticKadane",
    samples = "Samples"
  ),
  definition = function(x, model, samples) {
    assert_probabilities(x)
    assert_subset(c("rho0", "gamma"), names(samples))
    assert_length(x, len = size(samples))

    rho0 <- samples@data$rho0
    gamma <- samples@data$gamma
    theta <- model@theta
    xmin <- model@xmin
    num <- gamma * (logit(x) - logit(rho0)) + xmin * (logit(theta) - logit(x))
    num / (logit(theta) - logit(rho0))
  }
)

## LogisticKadaneBetaGamma ----

#' @describeIn dose compute the dose level reaching a specific target
#'   probability of the occurrence of a DLE (`x`).
#'
#' @aliases dose-LogisticKadaneBetaGamma
#' @export
#'
setMethod(
  f = "dose",
  signature = signature(
    x = "numeric",
    model = "LogisticKadaneBetaGamma",
    samples = "Samples"
  ),
  definition = function(x, model, samples) {
    assert_probabilities(x)
    assert_subset(c("rho0", "gamma"), names(samples))
    assert_length(x, len = size(samples))

    rho0 <- samples@data$rho0
    gamma <- samples@data$gamma
    theta <- model@theta
    xmin <- model@xmin
    num <- gamma * (logit(x) - logit(rho0)) + xmin * (logit(theta) - logit(x))
    num / (logit(theta) - logit(rho0))
  }
)

## LogisticNormalMixture ----

#' @describeIn dose compute the dose level reaching a specific target
#'   probability of the occurrence of a DLE (`x`).
#'
#' @aliases dose-LogisticNormalMixture
#' @export
#'
setMethod(
  f = "dose",
  signature = signature(
    x = "numeric",
    model = "LogisticNormalMixture",
    samples = "Samples"
  ),
  definition = function(x, model, samples) {
    assert_probabilities(x)
    assert_subset(c("alpha0", "alpha1"), names(samples))
    assert_length(x, len = size(samples))

    alpha0 <- samples@data$alpha0
    alpha1 <- samples@data$alpha1
    ref_dose <- as.numeric(model@ref_dose)
    exp((logit(x) - alpha0) / alpha1) * ref_dose
  }
)

## LogisticNormalFixedMixture ----

#' @describeIn dose compute the dose level reaching a specific target
#'   probability of the occurrence of a DLE (`x`).
#'
#' @aliases dose-LogisticNormalFixedMixture
#' @export
#'
setMethod(
  f = "dose",
  signature = signature(
    x = "numeric",
    model = "LogisticNormalFixedMixture",
    samples = "Samples"
  ),
  definition = function(x, model, samples) {
    assert_probabilities(x)
    assert_subset(c("alpha0", "alpha1"), names(samples))
    assert_length(x, len = size(samples))

    alpha0 <- samples@data$alpha0
    alpha1 <- samples@data$alpha1
    ref_dose <- as.numeric(model@ref_dose)
    exp((logit(x) - alpha0) / alpha1) * ref_dose
  }
)

## LogisticLogNormalMixture ----

#' @describeIn dose compute the dose level reaching a specific target
#'   probability of the occurrence of a DLE (`x`).
#'
#' @aliases dose-LogisticLogNormalMixture
#' @export
#'
setMethod(
  f = "dose",
  signature = signature(
    x = "numeric",
    model = "LogisticLogNormalMixture",
    samples = "Samples"
  ),
  definition = function(x, model, samples) {
    stop("not implemented")
  }
)

## DualEndpoint ----

#' @describeIn dose compute the dose level reaching a specific target
#'   probability of the occurrence of a DLE (`x`).
#'
#' @aliases dose-DualEndpoint
#' @export
#'
setMethod(
  f = "dose",
  signature = signature(
    x = "numeric",
    model = "DualEndpoint",
    samples = "Samples"
  ),
  definition = function(x, model, samples) {
    assert_probabilities(x)
    assert_subset("betaZ", names(samples))
    assert_length(x, len = size(samples))

    betaZ <- samples@data$betaZ
    ref_dose <- as.numeric(model@ref_dose)
    dose_temp <- (qnorm(x) - betaZ[, 1]) / betaZ[, 2]
    if (model@use_log_dose) {
      exp(dose_temp) * ref_dose
    } else {
      dose_temp * ref_dose
    }
  }
)

## LogisticIndepBeta ----

#' @describeIn dose compute the dose level reaching a specific target
#'   probability of the occurrence of a DLE (`x`).
#'
#' @aliases dose-LogisticIndepBeta
#' @export
#'
setMethod(
  f = "dose",
  signature = signature(
    x = "numeric",
    model = "LogisticIndepBeta",
    samples = "Samples"
  ),
  definition = function(x, model, samples) {
    assert_probabilities(x)
    assert_subset(c("phi1", "phi2"), names(samples))
    assert_length(x, len = size(samples))

    phi1 <- samples@data$phi1
    phi2 <- samples@data$phi2
    log_dose <- (log(x / (1 - x)) - phi1) / phi2
    exp(log_dose)
  }
)

## LogisticIndepBeta-noSamples ----

#' @describeIn dose compute the dose level reaching a specific target
#'   probability of the occurrence of a DLE (`x`).
#'   All model parameters (except `x`) should be present in the `model` object.
#'
#' @aliases dose-LogisticIndepBeta-noSamples
#' @export
#'
setMethod(
  f = "dose",
  signature = signature(
    x = "numeric",
    model = "LogisticIndepBeta",
    samples = "missing"
  ),
  definition = function(x, model) {
    assert_probabilities(x)
    model_params <- h_slots(model, c("phi1", "phi2"))
    nsamples <- length(model_params[[1]])
    samples <- Samples(data = model_params, options = McmcOptions(samples = nsamples))
    assert_length(x, len = nsamples)

    dose(x, model, samples)
  }
)

## Effloglog-noSamples ----

#' @describeIn dose compute the dose level reaching a specific target
#'   probability of the occurrence of a DLE (`x`).
#'   All model parameters (except `x`) should be present in the `model` object.
#'
#' @aliases dose-Effloglog-noSamples
#' @export
#'
setMethod(
  f = "dose",
  signature = signature(
    x = "numeric",
    model = "Effloglog",
    samples = "missing"
  ),
  definition = function(x, model) {
    assert_numeric(x, min.len = 1L, any.missing = FALSE, finite = TRUE)
    theta1 <- model@theta1
    theta2 <- model@theta2
    constant <- model@const
    assert_scalar(theta1)
    assert_scalar(theta2)
    assert_scalar(constant)

    exp(exp((x - theta1) / theta2)) - constant
  }
)

## EffFlexi ----

#' @describeIn dose compute the dose level reaching a specific target
#'   probability of the occurrence of a DLE (`x`). For this method `x` must
#'   be a scalar.
#'
#' @aliases dose-EffFlexi
#' @export
#'
setMethod(
  f = "dose",
  signature = signature(
    x = "numeric",
    model = "EffFlexi",
    samples = "Samples"
  ),
  definition = function(x, model, samples) {
    assert_number(x)
    assert_subset("ExpEff", names(samples))

    samples_efficacy <- samples@data$ExpEff
    dose_grid <- model@data@doseGrid

    # Find dose level for a given expected efficacy level using linear interpolation.
    apply(samples_efficacy, 1, function(se) {
      se_leq_x <- se <= x
      dose_level0 <- max(which(se_leq_x))
      dose_level1 <- min(which(!se_leq_x))
      eff0 <- se[dose_level0]
      eff1 <- se[dose_level1]
      dose0 <- dose_grid[dose_level0]
      dose1 <- dose_grid[dose_level1]
      dose0 + (dose1 - dose0) * ((x - eff0) / (eff1 - eff0))
    })
  }
)

## OneParLogNormalPrior ----

#' @describeIn dose compute the dose level reaching a specific target
#'   probability of the occurrence of a DLT (`x`).
#'
#' @aliases dose-OneParLogNormalPrior
#' @export
#'
setMethod(
  f = "dose",
  signature = signature(
    x = "numeric",
    model = "OneParLogNormalPrior",
    samples = "Samples"
  ),
  definition = function(x, model, samples) {
    assert_probabilities(x)
    assert_subset("alpha", names(samples))
    assert_length(x, len = size(samples))

    alpha <- samples@data$alpha
    skel_fun_inv <- model@skel_fun_inv
    skel_fun_inv(x^(1 / exp(alpha)))
  }
)

## OneParExpPrior ----

#' @describeIn dose compute the dose level reaching a specific target
#'   probability of the occurrence of a DLT (`x`).
#'
#' @aliases dose-OneParExpPrior
#' @export
#'
setMethod(
  f = "dose",
  signature = signature(
    x = "numeric",
    model = "OneParExpPrior",
    samples = "Samples"
  ),
  definition = function(x, model, samples) {
    assert_probabilities(x)
    assert_subset("theta", names(samples))
    assert_length(x, len = size(samples))

    theta <- samples@data$theta
    skel_fun_inv <- model@skel_fun_inv
    assert_numeric(theta, lower = .Machine$double.xmin, finite = TRUE)
    skel_fun_inv(x^(1 / theta))
  }
)

# prob ----

## generic ----

#' Computing Toxicity Probabilities for a Given Dose, Model and Samples
#'
#' @description `r lifecycle::badge("stable")`
#'
#' A function that computes the probability of the occurrence of a DLE at a
#' specified dose level, based on the model parameters (samples).
#'
#' @details The `prob()` function computes the probability of toxicity for given
#'   doses, using samples of the model parameter(s).
#'   If you work with multivariate model parameters, then assume that your model
#'   specific `prob()` method receives a samples matrix where the rows
#'   correspond to the sampling index, i.e. the layout is then
#'   `nSamples x dimParameter`.
#'
#' @note The [prob()] and [dose()] functions are the inverse of
#'   each other, for all [dose()] methods for which its first argument, i.e. a
#'   given independent variable that dose depends on, represents toxicity
#'   probability.
#'
#' @param dose (`number` or `numeric`)\cr the dose which is targeted.
#'   The following recycling rule applies when `samples` is not missing: vectors
#'   of size 1 will be recycled to the size of the sample
#'   (i.e. `size(samples)`). Otherwise, `dose` must have the same
#'   size as the sample.
#' @param model (`GeneralModel` or `ModelTox`)\cr the model for single agent
#'   dose escalation or pseudo DLE (dose-limiting events)/toxicity model.
#' @param samples (`Samples`)\cr the samples of model's parameters that will be
#'   used to compute toxicity probabilities. Can also be missing for some models.
#' @param ... model specific parameters when `samples` are not used.
#'
#' @return A `proportion` or `numeric` vector with the toxicity probabilities.
#'   If non-scalar `samples` were used, then every element in the returned vector
#'   corresponds to one element of a sample. Hence, in this case, the output
#'   vector is of the same length as the sample vector. If scalar `samples` were
#'   used or no `samples` were used, e.g. for pseudo DLE/toxicity `model`,
#'   then the output is of the same length as the length of the `dose`.  In the
#'   case of `LogisticLogNormalOrdinal`, the probabilities relate to toxicities
#'   of  grade given by `grade`.
#'
#' @seealso [probFunction()], [dose()], [efficacy()].
#'
#' @export
#' @example examples/Model-method-prob.R
#'
setGeneric(
  name = "prob",
  def = function(dose, model, samples, ...) {
    standardGeneric("prob")
  },
  valueClass = c("numeric", "list")
)

## LogisticNormal ----

#' @describeIn prob
#'
#' @aliases prob-LogisticNormal
#' @export
#'
setMethod(
  f = "prob",
  signature = signature(
    dose = "numeric",
    model = "LogisticNormal",
    samples = "Samples"
  ),
  definition = function(dose, model, samples) {
    assert_numeric(dose, lower = 0L, any.missing = FALSE, min.len = 1)
    assert_subset(c("alpha0", "alpha1"), names(samples))
    assert_length(dose, len = size(samples))

    alpha0 <- samples@data$alpha0
    alpha1 <- samples@data$alpha1
    ref_dose <- as.numeric(model@ref_dose)
    plogis(alpha0 + alpha1 * log(dose / ref_dose))
  }
)

## LogisticLogNormal ----

#' @describeIn prob
#'
#' @aliases prob-LogisticLogNormal
#' @export
#'
setMethod(
  f = "prob",
  signature = signature(
    dose = "numeric",
    model = "LogisticLogNormal",
    samples = "Samples"
  ),
  definition = function(dose, model, samples) {
    assert_numeric(dose, lower = 0L, any.missing = FALSE, min.len = 1L)
    assert_subset(c("alpha0", "alpha1"), names(samples))
    assert_length(dose, len = size(samples))

    alpha0 <- samples@data$alpha0
    alpha1 <- samples@data$alpha1
    ref_dose <- as.numeric(model@ref_dose)
    plogis(alpha0 + alpha1 * log(dose / ref_dose))
  }
)

## LogisticLogNormalSub ----

#' @describeIn prob
#'
#' @aliases prob-LogisticLogNormalSub
#' @export
#'
setMethod(
  f = "prob",
  signature = signature(
    dose = "numeric",
    model = "LogisticLogNormalSub",
    samples = "Samples"
  ),
  definition = function(dose, model, samples) {
    assert_numeric(dose, lower = 0L, any.missing = FALSE, min.len = 1L)
    assert_subset(c("alpha0", "alpha1"), names(samples))
    assert_length(dose, len = size(samples))

    alpha0 <- samples@data$alpha0
    alpha1 <- samples@data$alpha1
    ref_dose <- model@ref_dose
    plogis(alpha0 + alpha1 * (dose - ref_dose))
  }
)

## ProbitLogNormal ----

#' @describeIn prob
#'
#' @aliases prob-ProbitLogNormal
#' @export
#'
setMethod(
  f = "prob",
  signature = signature(
    dose = "numeric",
    model = "ProbitLogNormal",
    samples = "Samples"
  ),
  definition = function(dose, model, samples) {
    assert_numeric(dose, lower = 0L, any.missing = FALSE, min.len = 1L)
    assert_subset(c("alpha0", "alpha1"), names(samples))
    assert_length(dose, len = size(samples))

    alpha0 <- samples@data$alpha0
    alpha1 <- samples@data$alpha1
    ref_dose <- as.numeric(model@ref_dose)
    pnorm(alpha0 + alpha1 * log(dose / ref_dose))
  }
)

## ProbitLogNormalRel ----

#' @describeIn prob
#'
#' @aliases prob-ProbitLogNormalRel
#' @export
#'
setMethod(
  f = "prob",
  signature = signature(
    dose = "numeric",
    model = "ProbitLogNormalRel",
    samples = "Samples"
  ),
  definition = function(dose, model, samples) {
    assert_numeric(dose, lower = 0L, any.missing = FALSE, min.len = 1L)
    assert_subset(c("alpha0", "alpha1"), names(samples))
    assert_length(dose, len = size(samples))

    alpha0 <- samples@data$alpha0
    alpha1 <- samples@data$alpha1
    ref_dose <- as.numeric(model@ref_dose)
    pnorm(alpha0 + alpha1 * (dose / ref_dose))
  }
)

## LogisticLogNormalGrouped ----

#' @describeIn prob method for [`LogisticLogNormalGrouped`] which needs `group`
#'   argument in addition.
#' @param group (`character` or `factor`)\cr for [`LogisticLogNormalGrouped`],
#'   indicating whether to calculate the probability for the `mono` or for
#'   the `combo` arm.
#' @aliases prob-LogisticLogNormalGrouped
#' @export
#'
setMethod(
  f = "prob",
  signature = signature(
    dose = "numeric",
    model = "LogisticLogNormalGrouped",
    samples = "Samples"
  ),
  definition = function(dose, model, samples, group) {
    assert_numeric(dose, lower = 0L, any.missing = FALSE, min.len = 1L)
    assert_subset(c("alpha0", "delta0", "alpha1", "delta1"), names(samples))
    assert_length(dose, len = size(samples))
    assert_multi_class(group, c("character", "factor"))
    assert_subset(as.character(group), choices = c("mono", "combo"))
    assert_length(group, len = size(samples))

    alpha0 <- samples@data$alpha0
    delta0 <- samples@data$delta0
    alpha1 <- samples@data$alpha1
    delta1 <- samples@data$delta1
    ref_dose <- as.numeric(model@ref_dose)
    is_combo <- as.integer(group == "combo")
    plogis((alpha0 + is_combo * delta0) + (alpha1 + is_combo * delta1) * log(dose / ref_dose))
  }
)

## LogisticKadane ----

#' @describeIn prob
#'
#' @aliases prob-LogisticKadane
#' @export
#'
setMethod(
  f = "prob",
  signature = signature(
    dose = "numeric",
    model = "LogisticKadane",
    samples = "Samples"
  ),
  definition = function(dose, model, samples) {
    assert_numeric(dose, lower = 0L, any.missing = FALSE, min.len = 1L)
    assert_subset(c("rho0", "gamma"), names(samples))
    assert_length(dose, len = size(samples))

    rho0 <- samples@data$rho0
    gamma <- samples@data$gamma
    theta <- model@theta
    xmin <- model@xmin
    num <- gamma * logit(rho0) - xmin * logit(theta) + (logit(theta) - logit(rho0)) * dose
    plogis(num / (gamma - xmin))
  }
)

## LogisticKadaneBetaGamma ----

#' @describeIn prob
#'
#' @aliases prob-LogisticKadaneBetaGamma
#' @export
#'
setMethod(
  f = "prob",
  signature = signature(
    dose = "numeric",
    model = "LogisticKadaneBetaGamma",
    samples = "Samples"
  ),
  definition = function(dose, model, samples) {
    assert_numeric(dose, lower = 0L, any.missing = FALSE, min.len = 1L)
    assert_subset(c("rho0", "gamma"), names(samples))
    assert_length(dose, len = size(samples))

    rho0 <- samples@data$rho0
    gamma <- samples@data$gamma
    theta <- model@theta
    xmin <- model@xmin
    num <- gamma * logit(rho0) - xmin * logit(theta) + (logit(theta) - logit(rho0)) * dose
    plogis(num / (gamma - xmin))
  }
)

## LogisticNormalMixture ----

#' @describeIn prob
#'
#' @aliases prob-LogisticNormalMixture
#' @export
#'
setMethod(
  f = "prob",
  signature = signature(
    dose = "numeric",
    model = "LogisticNormalMixture",
    samples = "Samples"
  ),
  definition = function(dose, model, samples) {
    assert_numeric(dose, lower = 0L, any.missing = FALSE, min.len = 1L)
    assert_subset(c("alpha0", "alpha1"), names(samples))
    assert_length(dose, len = size(samples))

    alpha0 <- samples@data$alpha0
    alpha1 <- samples@data$alpha1
    ref_dose <- as.numeric(model@ref_dose)
    plogis(alpha0 + alpha1 * log(dose / ref_dose))
  }
)

## LogisticNormalFixedMixture ----

#' @describeIn prob
#'
#' @aliases prob-LogisticNormalFixedMixture
#' @export
#'
setMethod(
  f = "prob",
  signature = signature(
    dose = "numeric",
    model = "LogisticNormalFixedMixture",
    samples = "Samples"
  ),
  definition = function(dose, model, samples) {
    assert_numeric(dose, lower = 0L, any.missing = FALSE, min.len = 1L)
    assert_subset(c("alpha0", "alpha1"), names(samples))
    assert_length(dose, len = size(samples))

    alpha0 <- samples@data$alpha0
    alpha1 <- samples@data$alpha1
    ref_dose <- as.numeric(model@ref_dose)
    plogis(alpha0 + alpha1 * log(dose / ref_dose))
  }
)

## LogisticLogNormalMixture ----

#' @describeIn prob
#'
#' @aliases prob-LogisticLogNormalMixture
#' @export
#'
setMethod(
  f = "prob",
  signature = signature(
    dose = "numeric",
    model = "LogisticLogNormalMixture",
    samples = "Samples"
  ),
  definition = function(dose, model, samples) {
    assert_numeric(dose, lower = 0L, any.missing = FALSE, min.len = 1L)
    assert_subset(c("alpha0", "alpha1"), names(samples))
    assert_length(dose, len = size(samples))

    alpha0 <- samples@data$alpha0
    alpha1 <- samples@data$alpha1
    comp <- samples@data$comp
    ref_dose <- as.numeric(model@ref_dose)
    sel <- cbind(seq_along(comp), comp)
    plogis(alpha0[sel] + alpha1[sel] * log(dose / ref_dose))
  }
)

## DualEndpoint ----

#' @describeIn prob
#'
#' @aliases prob-DualEndpoint
#' @export
#'
setMethod(
  f = "prob",
  signature = signature(
    dose = "numeric",
    model = "DualEndpoint",
    samples = "Samples"
  ),
  definition = function(dose, model, samples) {
    assert_numeric(dose, lower = 0L, any.missing = FALSE, min.len = 1L)
    assert_subset("betaZ", names(samples))
    assert_length(dose, len = size(samples))

    betaZ <- samples@data$betaZ
    ref_dose <- as.numeric(model@ref_dose)
    stand_dose <- if (model@use_log_dose) {
      log(dose / ref_dose)
    } else {
      dose / ref_dose
    }
    pnorm(betaZ[, 1] + betaZ[, 2] * stand_dose)
  }
)

## LogisticIndepBeta ----

#' @describeIn prob compute toxicity probabilities of the occurrence of a DLE at
#' a specified dose level, based on the samples of [`LogisticIndepBeta`] model
#' parameters.
#'
#' @aliases prob-LogisticIndepBeta
#' @export
#'
setMethod(
  f = "prob",
  signature = signature(
    dose = "numeric",
    model = "LogisticIndepBeta",
    samples = "Samples"
  ),
  definition = function(dose, model, samples) {
    assert_numeric(dose, lower = 0L, any.missing = FALSE, min.len = 1L)
    assert_subset(c("phi1", "phi2"), names(samples))
    assert_length(dose, len = size(samples))

    phi1 <- samples@data$phi1
    phi2 <- samples@data$phi2
    log_dose <- log(dose)
    exp(phi1 + phi2 * log_dose) / (1 + exp(phi1 + phi2 * log_dose))
  }
)

## LogisticIndepBeta-noSamples ----

#' @describeIn prob compute toxicity probabilities of the occurrence of a DLE at
#' a specified dose level, based on the [`LogisticIndepBeta`] model parameters.
#' All model parameters (except `dose`) should be present in the `model` object.
#'
#' @aliases prob-LogisticIndepBeta-noSamples
#' @export
#'
setMethod(
  f = "prob",
  signature = signature(
    dose = "numeric",
    model = "LogisticIndepBeta",
    samples = "missing"
  ),
  definition = function(dose, model) {
    model_params <- h_slots(model, c("phi1", "phi2"))
    nsamples <- length(model_params[[1]])
    samples <- Samples(data = model_params, options = McmcOptions(samples = nsamples))

    assert_numeric(dose, lower = 0L, any.missing = FALSE, min.len = 1L)
    assert_length(dose, len = nsamples)

    prob(dose, model, samples)
  }
)

## OneParLogNormalPrior ----

#' @describeIn prob
#'
#' @aliases prob-OneParLogNormalPrior
#' @export
#'
setMethod(
  f = "prob",
  signature = signature(
    dose = "numeric",
    model = "OneParLogNormalPrior",
    samples = "Samples"
  ),
  definition = function(dose, model, samples) {
    assert_numeric(dose, lower = 0L, any.missing = FALSE, min.len = 1L)
    assert_subset("alpha", names(samples))
    assert_length(dose, len = size(samples))

    alpha <- samples@data$alpha
    skel_fun <- model@skel_fun
    skel_fun(dose)^exp(alpha)
  }
)

## OneParExpPrior ----

#' @describeIn prob
#'
#' @aliases prob-OneParExpPrior
#' @export
#'
setMethod(
  f = "prob",
  signature = signature(
    dose = "numeric",
    model = "OneParExpPrior",
    samples = "Samples"
  ),
  definition = function(dose, model, samples) {
    assert_numeric(dose, lower = 0L, any.missing = FALSE, min.len = 1L)
    assert_subset("theta", names(samples))
    assert_length(dose, len = size(samples))

    theta <- samples@data$theta
    skel_fun <- model@skel_fun
    skel_fun(dose)^theta
  }
)

## LogisticLogNormalOrdinal ----

#' Calculate a grade-specific probability of toxicity for a given dose.
#' @describeIn prob
#'
#' @param grade (`integer` or `integer_vector`)\cr The toxicity grade for which probabilities are required
#' @param cumulative (`flag`)\cr Should the returned probability be cumulative
#' (the default) or grade-specific?
#' @aliases prob-LogisticLogNormalOrdinal
#' @export
#'
setMethod(
  f = "prob",
  signature = signature(
    dose = "numeric",
    model = "LogisticLogNormalOrdinal",
    samples = "Samples"
  ),
  definition = function(dose, model, samples, grade, cumulative = TRUE) {
    assert_numeric(dose, lower = 0L, any.missing = FALSE, min.len = 1L)
    assert_integer(
      grade,
      min.len = 1,
      max.len = length(model@params@mean) - 1,
      lower = 0,
      upper = length(model@params@mean) - 1
    )
    assert_subset(
      names(samples),
      c(paste0("alpha", 0:(length(model@params@mean) - 1)), "beta")
    )
    assert_length(dose, len = size(samples))
    assert_flag(cumulative)

    rv <- lapply(
      grade,
      function(g) {
        alpha <- samples@data[[paste0("alpha", g)]]
        beta <- samples@data$beta
        ref_dose <- as.numeric(model@ref_dose)

        cumulative_prob <- plogis(alpha + beta * log(dose / ref_dose))
        if (cumulative | g == as.integer(length(model@params@mean) - 1)) {
          return(cumulative_prob)
        }

        # Calculate grade-specific probabilities
        alpha0 <- samples@data[[paste0("alpha", g + 1)]]
        grade_prob <- cumulative_prob - plogis(alpha0 + beta * log(dose / ref_dose))
        return(grade_prob)
      }
    )
    if (length(rv) == 1) {
      return(rv[[1]])
    }
    names(rv) <- as.character(grade)
    return(rv)
  }
)

# efficacy ----

## generic ----

#' Computing Expected Efficacy for a Given Dose, Model and Samples
#'
#' @description `r lifecycle::badge("stable")`
#'
#' A function that computes the value of expected efficacy at a specified dose
#' level, based on the model specific parameters. The model parameters (samples)
#' are obtained based on prior specified in form of pseudo data combined with
#' observed responses (if any).
#'
#' @details The `efficacy()` function computes the expected efficacy for given
#'   doses, using samples of the model parameter(s).
#'   If you work with multivariate model parameters, then assume that your model
#'   specific `efficacy()` method receives a samples matrix where the rows
#'   correspond to the sampling index, i.e. the layout is then
#'   `nSamples x dimParameter`.
#'
#' @param dose (`numeric`)\cr the dose which is targeted.
#'   The following recycling rule applies when `samples` is not missing: vectors
#'   of size 1 will be recycled to the size of the sample
#'   (i.e. `size(samples)`). Otherwise, `dose` must have the same
#'   size as the sample.
#' @param model (`ModelEff`)\cr the efficacy model with pseudo data prior.
#' @param samples (`Samples`)\cr samples of model's parameters that will be
#'   used to compute expected efficacy values. Can also be missing for some
#'   models.
#' @param ... model specific parameters when `samples` are not used.
#'
#' @return A `numeric` vector with the values of expected efficacy.
#'   If non-scalar `samples` were used, then every element in the returned vector
#'   corresponds to one element of a sample. Hence, in this case, the output
#'   vector is of the same length as the sample vector. If scalar `samples` were
#'   used or no `samples` were used, e.g. for pseudo DLE/toxicity `model`,
#'   then the output is of the same length as the length of the `dose`.
#'
#' @seealso [dose()], [prob()].
#'
#' @export
#' @example examples/Model-method-efficacy.R
setGeneric(
  name = "efficacy",
  def = function(dose, model, samples, ...) {
    standardGeneric("efficacy")
  },
  valueClass = "numeric"
)

## Effloglog ----

#' @describeIn efficacy compute the expected efficacy at a specified dose level,
#' based on the samples of [`Effloglog`] model parameters.
#'
#' @aliases efficacy-Effloglog
#' @export
#'
setMethod(
  f = "efficacy",
  signature = signature(
    dose = "numeric",
    model = "Effloglog",
    samples = "Samples"
  ),
  definition = function(dose, model, samples) {
    assert_numeric(dose, lower = 0L, any.missing = FALSE, min.len = 1L)
    assert_subset(c("theta1", "theta2"), names(samples))
    assert_length(dose, len = size(samples))

    theta1 <- samples@data$theta1
    theta2 <- samples@data$theta2
    constant <- model@const
    theta1 + theta2 * log(log(dose + constant))
  }
)

## Effloglog-noSamples ----

#' @describeIn efficacy compute the expected efficacy at a specified dose level,
#' based on the [`Effloglog`] model parameters.
#' All model parameters (except `dose`) should be present in the `model` object.
#'
#' @aliases efficacy-Effloglog-noSamples
#' @export
#'
setMethod(
  f = "efficacy",
  signature = signature(
    dose = "numeric",
    model = "Effloglog",
    samples = "missing"
  ),
  definition = function(dose, model) {
    model_params <- h_slots(model, c("theta1", "theta2"))
    nsamples <- length(model_params[[1]])
    samples <- Samples(data = model_params, options = McmcOptions(samples = nsamples))

    assert_numeric(dose, lower = 0L, any.missing = FALSE, min.len = 1L)
    assert_length(dose, len = nsamples)

    efficacy(dose, model, samples)
  }
)

## EffFlexi ----

#' @describeIn efficacy compute the expected efficacy at a specified dose level,
#' based on the samples of [`EffFlexi`] model parameters. If a given dose in
#' the `dose` vector is from outside of the dose grid range, the `NA_real` is
#' returned for this dose and the warning is thrown.
#'
#' @aliases efficacy-EffFlexi
#' @export
#'
setMethod(
  f = "efficacy",
  signature = signature(
    dose = "numeric",
    model = "EffFlexi",
    samples = "Samples"
  ),
  definition = function(dose, model, samples) {
    n_samples <- size(samples)
    assert_numeric(dose, lower = 0L, any.missing = FALSE, min.len = 1L)
    assert_true(model@data@nGrid >= 1L)
    assert_subset("ExpEff", names(samples))
    assert_length(dose, len = n_samples)

    dose_grid <- model@data@doseGrid
    dose_level <- match_within_tolerance(dose, dose_grid)
    dose[which(!is.na(dose_level))] <- dose_grid[stats::na.omit(dose_level)]

    # linear interpolation, NA for doses that are outside of the dose_grid range.
    samples_eff <- samples@data$ExpEff
    eff <- if (length(dose) == n_samples) {
      sapply(seq_len(n_samples), function(s) {
        stats::approx(dose_grid, samples_eff[s, ], xout = dose[s])$y
      })
    } else {
      eff <- apply(samples_eff, 1, function(s) {
        stats::approx(dose_grid, s, xout = dose)$y
      })
      as.vector(eff)
    }

    if (any(is.na(eff))) {
      warning(
        paste("At least one dose out of", paste(dose, collapse = ", "), "is outside of the dose grid range")
      )
    }
    eff
  }
)

# biomarker ----

## generic ----

#' Get the Biomarker Levels for a Given Dual-Endpoint Model, Given Dose Levels and Samples
#'
#' @details This function simply returns a specific columns (with the indices equal
#' to `xLevel`) of the biomarker samples matrix, which is included in the the
#' `samples` object.
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' @param xLevel (`integer`)\cr the levels for the doses the patients have been
#'   given w.r.t dose grid. See [`Data`] for more details.
#' @param model (`DualEndpoint`)\cr the model.
#' @param samples (`Samples`)\cr the samples of model's parameters that store
#'   the value of biomarker levels for all doses on the dose grid.
#' @param ... not used.
#'
#' @return The biomarker levels.
#'
#' @export
#' @example examples/Model-method-biomarker.R
#'
setGeneric(
  name = "biomarker",
  def = function(xLevel, model, samples, ...) {
    standardGeneric("biomarker")
  },
  valueClass = c("numeric", "array")
)

## DualEndpoint ----

#' @describeIn biomarker
#'
#' @aliases biomarker-DualEndpoint
#' @export
#'
setMethod(
  f = "biomarker",
  signature = signature(
    xLevel = "integer",
    model = "DualEndpoint",
    samples = "Samples"
  ),
  def = function(xLevel, model, samples, ...) {
    assert_integer(
      xLevel,
      lower = 1,
      upper = ncol(samples@data$betaW),
      any.missing = FALSE,
      min.len = 1
    )

    samples@data$betaW[, xLevel]
  }
)

# gain ----

## generic ----

#' Compute Gain Values based on Pseudo DLE and a Pseudo Efficacy Models and
#' Using Optional Samples.
#'
#' @details This function computes the gain values for a given dose level,
#' pseudo DLE and Efficacy models as well as a given DLE and Efficacy samples.
#'
#' @description `r lifecycle::badge("stable")`
#'
#' @param dose (`number` or `numeric`)\cr the dose which is targeted.
#'   The following recycling rule applies when samples are not missing: vectors
#'   of size 1 will be recycled to the size of the sample. Otherwise, `dose`
#'   must have the same size as the sample.
#' @param model_dle (`ModelTox`)\cr pseudo DLE (dose-limiting events)/toxicity
#'   model.
#' @param samples_dle (`Samples`)\cr the samples of model's
#'   parameters that will be used to compute toxicity probabilities. Can also be
#'   missing for some models.
#' @param model_eff (`ModelEff`)\cr the efficacy model with pseudo data prior.
#' @param samples_eff (`Samples`)\cr samples of model's parameters that will be
#'   used to compute expected efficacy values. Can also be missing for some
#'   models.
#' @param ... not used.
#'
#' @return The gain values.
#'
#' @export
#' @example examples/Model-method-gain.R
#'
setGeneric(
  name = "gain",
  def = function(dose, model_dle, samples_dle, model_eff, samples_eff, ...) {
    standardGeneric("gain")
  },
  valueClass = "numeric"
)

## ModelTox-ModelEff ----

#' @describeIn gain
#'
#' @aliases gain-ModelTox-ModelEff
#' @export
#'
setMethod(
  f = "gain",
  signature = signature(
    dose = "numeric",
    model_dle = "ModelTox",
    samples_dle = "Samples",
    model_eff = "ModelEff",
    samples_eff = "Samples"
  ),
  definition = function(dose, model_dle, samples_dle, model_eff, samples_eff, ...) {
    dle <- prob(dose, model_dle, samples_dle)
    eff <- efficacy(dose, model_eff, samples_eff)
    assert_length(dle, len = length(eff))
    eff / (1 + (dle / (1 - dle)))
  }
)

## ModelTox-ModelEff-noSamples----

#' @describeIn gain Compute the gain value for a given dose level, pseudo DLE
#'   and Efficacy models without DLE and the Efficacy samples.
#'
#' @aliases gain-ModelTox-Effloglog-noSamples
#' @export
#' @example examples/Model-method-gainNoSamples.R
#'
setMethod(
  f = "gain",
  signature = signature(
    dose = "numeric",
    model_dle = "ModelTox",
    samples_dle = "missing",
    model_eff = "Effloglog",
    samples_eff = "missing"
  ),
  definition = function(dose, model_dle, model_eff, ...) {
    dle <- prob(dose, model_dle)
    eff <- efficacy(dose, model_eff)
    assert_length(dle, len = length(eff))
    eff / (1 + (dle / (1 - dle)))
  }
)

# update ----

## ModelPseudo ----

#' Update method for the [`ModelPseudo`] model class. This is a method to update
#' the model class slots (estimates, parameters, variables and etc.), when the
#' new data (e.g. new observations of responses) are available. This method is
#' mostly used to obtain new modal estimates for pseudo model parameters.
#'
#' @param object (`ModelPseudo`)\cr the model to update.
#' @param data (`Data`)\cr all currently available of data.
#' @param ... not used.
#'
#' @return the new [`ModelPseudo`] class object.
#'
#' @aliases update-ModelPseudo
#' @export
#' @example examples/Model-method-update.R
#'
setMethod(
  f = "update",
  signature = signature(
    object = "ModelPseudo"
  ),
  definition = function(object, data, ...) {
    assert_class(data, "Data")

    constructor_name <- class(object)
    arg_names <- setdiff(formalArgs(constructor_name), "data")
    do.call(
      constructor_name,
      c(h_slots(object, arg_names), list(data = data))
    )
  }
)

# NextBest ----

#' Internal Helper Functions for Validation of [`NextBest`] Objects
#'
#' @description `r lifecycle::badge("stable")`
#'
#' These functions are only used internally to validate the format of an input
#' [`NextBest`] or inherited classes and therefore not exported.
#'
#' @name v_next_best
#' @param object (`NextBest`)\cr object to validate.
#' @return A `character` vector with the validation failure messages,
#'   or `TRUE` in case validation passes.
NULL

#' @describeIn v_next_best validates that the [`NextBestMTD`] object
#'   contains valid `target` probability and `derive` function.
v_next_best_mtd <- function(object) {
  v <- Validate()
  v$check(
    test_probability(object@target, bounds_closed = FALSE),
    "target must be a probability value from (0, 1) interval"
  )
  v$check(
    test_function(object@derive, nargs = 1),
    "derive must have a single argument"
  )
  v$check(
    test_number(object@derive(1:5)),
    "derive must accept numerical vector as an argument and return a number"
  )
  v$result()
}

#' @describeIn v_next_best validates that the [`NextBestNCRM`] object
#'   contains valid `target` probability, `overdose` and `max_overdose_prob`
#'   probability ranges.
v_next_best_ncrm <- function(object) {
  v <- Validate()
  v$check(
    test_probability_range(object@target),
    "target has to be a probability range"
  )
  v$check(
    test_probability_range(object@overdose),
    "overdose has to be a probability range"
  )
  v$check(
    test_probability(object@max_overdose_prob, bounds_closed = FALSE),
    "max_overdose_prob must be a probability value from (0, 1) interval"
  )
  v$result()
}

#' @describeIn v_next_best validates that the [`NextBestNCRMLoss`] object
#'   contains valid objects.
v_next_best_ncrm_loss <- function(object) {
  v <- Validate()
  v$check(
    test_probability_range(object@target, bounds_closed = FALSE),
    "target has to be a probability range excluding 0 and 1"
  )

  is_overdose_ok <- test_probability_range(object@overdose, bounds_closed = TRUE)
  v$check(is_overdose_ok, "overdose has to be a probability range")

  is_unacceptable_ok <- test_probability_range(object@unacceptable, bounds_closed = TRUE)
  v$check(is_unacceptable_ok, "unacceptable has to be a probability range")

  if (is_overdose_ok && is_unacceptable_ok) {
    v$check(
      object@overdose[2] <= object@unacceptable[1],
      "lower bound of unacceptable has to be >= than upper bound of overdose"
    )
  }
  if (is_unacceptable_ok) {
    losses_len <- ifelse(all(object@unacceptable == c(1, 1)), 3L, 4L)
    v$check(
      test_numeric(object@losses, lower = 0, finite = TRUE, any.missing = FALSE, len = losses_len),
      "losses must be a vector of non-negative numbers of length 3 if unacceptable is c(1, 1), otherwise 4"
    )
  }
  v$result()
}

#' @describeIn v_next_best validates that the [`NextBestDualEndpoint`] object
#'   contains valid probability objects.
v_next_best_dual_endpoint <- function(object) {
  v <- Validate()
  v$check(
    test_flag(object@target_relative),
    "target_relative must be a flag"
  )
  if (isTRUE(object@target_relative)) {
    v$check(
      test_probability_range(object@target),
      "target has to be a probability range when target_relative is TRUE"
    )
  } else {
    v$check(
      test_range(object@target),
      "target must be a numeric range"
    )
  }
  v$check(
    test_probability_range(object@overdose),
    "overdose has to be a probability range"
  )
  v$check(
    test_probability(object@max_overdose_prob, bounds_closed = FALSE),
    "max_overdose_prob must be a probability value from (0, 1) interval"
  )
  v$check(
    test_probability(object@target_thresh),
    "target_thresh must be a probability value from [0, 1] interval"
  )
  v$result()
}

#' @describeIn v_next_best validates that the [`NextBestMinDist`] object
#'   contains valid `target` object.
v_next_best_min_dist <- function(object) {
  v <- Validate()
  v$check(
    test_probability(object@target, bounds_closed = FALSE),
    "target must be a probability value from (0, 1) interval"
  )
  v$result()
}

#' @describeIn v_next_best validates that the [`NextBestInfTheory`] object
#'   contains valid `target` and `asymmetry` objects.
v_next_best_inf_theory <- function(object) {
  v <- Validate()
  v$check(
    test_probability(object@target, bounds_closed = FALSE),
    "target must be a probability value from (0, 1) interval"
  )
  v$check(
    test_number(object@asymmetry, finite = TRUE) && h_in_range(object@asymmetry, c(0, 2), FALSE),
    "asymmetry must be a number from (0, 2) interval"
  )
  v$result()
}

#' @describeIn v_next_best validates that the [`NextBestTD`] object
#'   contains valid `prob_target_drt` and `prob_target_eot` probabilities.
v_next_best_td <- function(object) {
  v <- Validate()
  v$check(
    test_probability(object@prob_target_drt, bounds_closed = FALSE),
    "prob_target_drt must be a probability value from (0, 1) interval"
  )
  v$check(
    test_probability(object@prob_target_eot, bounds_closed = FALSE),
    "prob_target_eot must be a probability value from (0, 1) interval"
  )
  v$result()
}

#' @describeIn v_next_best validates that the [`NextBestTDsamples`] object
#'   contains valid `derive` function.
v_next_best_td_samples <- function(object) {
  v <- Validate()
  v$check(
    test_function(object@derive, nargs = 1),
    "derive must have a single argument"
  )
  v$check(
    test_number(object@derive(1:5)),
    "derive must accept numerical vector as an argument and return a number"
  )
  v$result()
}

#' @describeIn v_next_best validates that the [`NextBestMaxGainSamples`] object
#'   contains valid `derive` and `mg_derive` functions.
v_next_best_max_gain_samples <- function(object) {
  v <- Validate()
  v$check(
    test_function(object@derive, nargs = 1),
    "derive must have a single argument"
  )
  v$check(
    test_number(object@derive(1:5)),
    "derive must accept numerical vector as an argument and return a number"
  )
  v$check(
    test_function(object@mg_derive, nargs = 1),
    "mg_derive must have a single argument"
  )
  v$check(
    test_number(object@mg_derive(1:5)),
    "mg_derive must accept numerical vector as an argument and return a number"
  )
  v$result()
}

#' @describeIn v_next_best validates that the [`NextBestProbMTDLTE`] object
#'   contains valid `target` probability and `method` string value.
v_next_best_prob_mtd_lte <- function(object) {
  v <- Validate()
  v$check(
    test_probability(object@target, bounds_closed = FALSE),
    "target must be a probability value from (0, 1) interval"
  )
  v$result()
}

#' @describeIn v_next_best validates that the [`NextBestProbMTDMinDist`] object
#'   contains valid `target` probability and `method` string value.
v_next_best_prob_mtd_min_dist <- function(object) {
  v <- Validate()
  v$check(
    test_probability(object@target, bounds_closed = FALSE),
    "target must be a probability value from (0, 1) interval"
  )
  v$result()
}

# Increments ----

#' Internal Helper Functions for Validation of [`Increments`] Objects
#'
#' @description `r lifecycle::badge("stable")`
#'
#' These functions are only used internally to validate the format of an input
#' [`Increments`] or inherited classes and therefore not exported.
#'
#' @name v_increments
#' @param object (`Increments`)\cr object to validate.
#' @return A `character` vector with the validation failure messages,
#'   or `TRUE` in case validation passes.
NULL

#' @describeIn v_increments validates that the [`IncrementsRelative`] object
#'   contains valid `intervals` and `increments` parameters.
v_increments_relative <- function(object) {
  v <- Validate()
  v$check(
    test_numeric(
      object@intervals,
      lower = 0, finite = TRUE, any.missing = FALSE, unique = TRUE, sorted = TRUE
    ),
    "intervals has to be a numerical vector with unique, finite, non-negative and sorted non-missing values"
  )
  v$check(
    test_numeric(object@increments, finite = TRUE, any.missing = FALSE, len = length(object@intervals)),
    "increments has to be a numerical vector of the same length as `intervals` with finite values"
  )
  v$result()
}

#' @describeIn v_increments validates that the [`IncrementsRelativeParts`] object
#'   contains valid `dlt_start` and `clean_start` parameters.
v_increments_relative_parts <- function(object) {
  v <- Validate()
  is_dlt_start_ok <- test_int(object@dlt_start)
  v$check(is_dlt_start_ok, "dlt_start must be an integer number")
  if (is_dlt_start_ok) {
    v$check(
      test_int(object@clean_start, lower = object@dlt_start),
      "clean_start must be an integer number and it must be >= dlt_start"
    )
  }
  v$result()
}

#' @describeIn v_increments validates that the [`IncrementsRelativeDLT`] object
#'   contains valid `intervals` and `increments` parameters.
v_increments_relative_dlt <- function(object) {
  v <- Validate()
  v$check(
    test_integer(object@intervals, lower = 0, any.missing = FALSE, unique = TRUE, sorted = TRUE),
    "intervals has to be an integer vector with unique, finite, non-negative and sorted non-missing values"
  )
  v$check(
    test_numeric(object@increments, finite = TRUE, any.missing = FALSE, len = length(object@intervals)),
    "increments has to be a numerical vector of the same length as `intervals` with finite values"
  )
  v$result()
}

#' @describeIn v_increments validates that the [`IncrementsDoseLevels`] object
#'   contains valid `levels` and `basis_level` option.
v_increments_dose_levels <- function(object) {
  v <- Validate()
  v$check(
    test_int(object@levels, lower = .Machine$double.xmin),
    "levels must be scalar positive integer"
  )
  v$check(
    test_string(object@basis_level, pattern = "^last$|^max$"),
    "basis_level must be either 'last' or 'max'"
  )
  v$result()
}

#' @describeIn v_increments validates that the [`IncrementsHSRBeta`]
#'   object contains valid probability target, threshold and shape parameters.
v_increments_hsr_beta <- function(object) {
  v <- Validate()
  v$check(
    test_probability(object@target, bounds_closed = FALSE),
    "target must be a probability value from (0, 1) interval"
  )
  v$check(
    test_probability(object@prob, bounds_closed = FALSE),
    "prob must be a probability value from (0, 1) interval"
  )
  v$check(
    test_number(object@a, lower = .Machine$double.xmin, finite = TRUE),
    "Beta distribution shape parameter a must be a positive scalar"
  )
  v$check(
    test_number(object@b, lower = .Machine$double.xmin, finite = TRUE),
    "Beta distribution shape parameter b must be a positive scalar"
  )
  v$result()
}

#' @describeIn v_increments validates that the [`IncrementsMin`]
#'   object contains a list with `Increments` objects.
v_increments_min <- function(object) {
  v <- Validate()
  v$check(
    all(sapply(object@increments_list, test_class, "Increments")),
    "all elements in increments_list must be of Increments class"
  )
  v$result()
}

# Stopping ----

#' Internal Helper Functions for Validation of [`Stopping`] Objects
#'
#' @description `r lifecycle::badge("stable")`
#'
#' These functions are only used internally to validate the format of an input
#' [`Stopping`] or inherited classes and therefore not exported.
#'
#' @name v_stopping
#' @param object (`Stopping`)\cr object to validate.
#' @return A `character` vector with the validation failure messages,
#'   or `TRUE` in case validation passes.
NULL

#' @describeIn v_stopping validates that the [`StoppingCohortsNearDose`]
#'   object contains valid `nCohorts` and `percentage` parameters.
v_stopping_cohorts_near_dose <- function(object) {
  v <- Validate()
  v$check(
    test_int(object@nCohorts, lower = .Machine$double.xmin),
    "nCohorts must be positive integer scalar"
  )
  v$check(
    test_probability(object@percentage / 100),
    "percentage must be a number between 0 and 100"
  )
  v$result()
}

#' @describeIn v_stopping validates that the [`StoppingPatientsNearDose`]
#'   object contains valid `nPatients` and `percentage` parameters.
v_stopping_patients_near_dose <- function(object) {
  v <- Validate()
  v$check(
    test_int(object@nPatients, lower = .Machine$double.xmin),
    "nPatients must be positive integer scalar"
  )
  v$check(
    test_probability(object@percentage / 100),
    "percentage must be a number between 0 and 100"
  )
  v$result()
}

#' @describeIn v_stopping validates that the [`StoppingMinCohorts`]
#'   object contains valid `nCohorts` parameter.
v_stopping_min_cohorts <- function(object) {
  v <- Validate()
  v$check(
    test_int(object@nCohorts, lower = .Machine$double.xmin),
    "nCohorts must be positive integer scalar"
  )
  v$result()
}

#' @describeIn v_stopping validates that the [`StoppingMinPatients`]
#'   object contains valid `nPatients` parameter.
v_stopping_min_patients <- function(object) {
  v <- Validate()
  v$check(
    test_int(object@nPatients, lower = .Machine$double.xmin),
    "nPatients must be positive integer scalar"
  )
  v$result()
}

#' @describeIn v_stopping validates that the [`StoppingTargetProb`]
#'   object contains valid `target` and `prob` parameters.
v_stopping_target_prob <- function(object) {
  v <- Validate()
  v$check(
    test_probability_range(object@target),
    "target has to be a probability range"
  )
  v$check(
    test_probability(object@prob, bounds_closed = FALSE),
    "prob must be a probability value from (0, 1) interval"
  )
  v$result()
}

#' @describeIn v_stopping validates that the [`StoppingMTDdistribution`]
#'   object contains valid `target`, `thresh` and `prob` parameters.
v_stopping_mtd_distribution <- function(object) {
  v <- Validate()
  v$check(
    test_probability(object@target, bounds_closed = FALSE),
    "target must be a probability value from (0, 1) interval"
  )
  v$check(
    test_probability(object@thresh, bounds_closed = FALSE),
    "thresh must be a probability value from (0, 1) interval"
  )
  v$check(
    test_probability(object@prob, bounds_closed = FALSE),
    "prob must be a probability value from (0, 1) interval"
  )
  v$result()
}

#' @describeIn v_stopping validates that the [`StoppingMTDCV`] object
#'   contains valid probability target and percentage threshold.
v_stopping_mtd_cv <- function(object) {
  v <- Validate()
  v$check(
    test_probability(object@target, bounds_closed = FALSE),
    "target must be probability value from (0, 1) interval"
  )
  v$check(
    test_probability(object@thresh_cv / 100, bounds_closed = c(FALSE, TRUE)),
    "thresh_cv must be percentage > 0"
  )
  v$result()
}

#' @describeIn v_stopping validates that the [`StoppingTargetBiomarker`] object
#'   contains valid `target`, `is_relative` and `prob`slots.
v_stopping_target_biomarker <- function(object) {
  v <- Validate()
  v$check(
    test_flag(object@is_relative),
    "is_relative must be a flag"
  )
  if (isTRUE(object@is_relative)) {
    v$check(
      test_probability_range(object@target),
      "target has to be a probability range when is_relative flag is 'TRUE'"
    )
  } else {
    v$check(
      test_range(object@target, finite = TRUE),
      "target must be a numeric range"
    )
  }
  v$check(
    test_probability(object@prob, bounds_closed = FALSE),
    "prob must be a probability value from (0, 1) interval"
  )
  v$result()
}

#' @describeIn v_stopping validates that the [`StoppingList`] object
#'   contains valid `stop_list`, `summary` slots.
v_stopping_list <- function(object) {
  v <- Validate()
  v$check(
    all(sapply(object@stop_list, test_class, "Stopping")),
    "every stop_list element must be of class 'Stopping'"
  )
  is_summary_ok <- test_function(object@summary, nargs = 1)
  v$check(
    is_summary_ok,
    "summary must be a function that accepts a single argument, without ..."
  )
  if (is_summary_ok) {
    summary_res <- object@summary(
      rep(c(TRUE, FALSE), length.out = length(object@stop_list))
    )
    v$check(
      test_flag(summary_res),
      "summary must accept a logical vector of the same length as 'stop_list' and return a boolean value"
    )
  }
  v$result()
}

#' @describeIn v_stopping validates that the [`StoppingAll`] object
#'   contains valid `stop_list` slot.
v_stopping_all <- function(object) {
  v <- Validate()
  v$check(
    all(sapply(object@stop_list, test_class, "Stopping")),
    "every stop_list element must be of class 'Stopping'"
  )
  v$result()
}

#' @describeIn v_stopping validates that the [`StoppingTDCIRatio`] object
#'   contains valid `target_ratio` and  `prob_target` slots.
v_stopping_tdci_ratio <- function(object) {
  v <- Validate()
  v$check(
    test_number(object@target_ratio, lower = .Machine$double.xmin, finite = TRUE),
    "target_ratio must be a positive number"
  )
  v$check(
    test_probability(object@prob_target),
    "prob_target must be a probability value from [0, 1] interval"
  )
  v$result()
}

# CohortSize ----

#' Internal Helper Functions for Validation of [`CohortSize`] Objects
#'
#' @description `r lifecycle::badge("stable")`
#'
#' These functions are only used internally to validate the format of an input
#' [`CohortSize`] or inherited classes and therefore not exported.
#'
#' @name v_cohort_size
#' @param object (`CohortSize`)\cr object to validate.
#' @return A `character` vector with the validation failure messages,
#'   or `TRUE` in case validation passes.
NULL

#' @describeIn v_cohort_size validates that the [`CohortSizeRange`] object
#'   contains valid `intervals` and  `cohort_size` slots.
v_cohort_size_range <- function(object) {
  v <- Validate()
  v$check(
    test_numeric(
      object@intervals,
      lower = 0, finite = TRUE, any.missing = FALSE, min.len = 1, unique = TRUE, sorted = TRUE
    ),
    "intervals must be a numeric vector with non-negative, sorted (asc.) and unique values"
  )
  v$check(
    test_integer(
      object@cohort_size,
      lower = 0, any.missing = FALSE, len = length(object@intervals)
    ),
    "cohort_size must be an integer vector of the same length as intervals, containing non-negative values only"
  )
  v$result()
}

#' @describeIn v_cohort_size validates that the [`CohortSizeDLT`] object
#'   contains valid `intervals` and  `cohort_size` slots.
v_cohort_size_dlt <- function(object) {
  v <- Validate()
  v$check(
    test_integer(
      object@intervals,
      lower = 0, any.missing = FALSE, min.len = 1, unique = TRUE, sorted = TRUE
    ),
    "intervals must be an integer vector with non-negative, sorted (asc.) and unique values"
  )
  v$check(
    test_integer(
      object@cohort_size,
      lower = 0, any.missing = FALSE, len = length(object@intervals)
    ),
    "cohort_size must be an integer vector of the same length as intervals, containing non-negative values only"
  )
  v$result()
}

#' @describeIn v_cohort_size validates that the [`CohortSizeConst`] object
#'   contains valid `size` slot.
v_cohort_size_const <- function(object) {
  v <- Validate()
  v$check(
    test_int(object@size, lower = 0),
    "size needs to be a non-negative scalar"
  )
  v$result()
}

#' @describeIn v_cohort_size validates that the [`CohortSizeParts`] object
#'   contains valid `sizes` slot.
v_cohort_size_parts <- function(object) {
  v <- Validate()
  v$check(
    test_integer(object@cohort_sizes, lower = .Machine$double.xmin, any.missing = FALSE, len = 2),
    "cohort_sizes needs to be an integer vector of length 2 with all elements positive"
  )
  v$result()
}

#' @describeIn v_cohort_size validates that the [`CohortSizeMax`] object
#'   contains valid `cohort_sizes` slot.
v_cohort_size_max <- function(object) {
  v <- Validate()
  v$check(
    test_list(object@cohort_sizes, types = "CohortSize", any.missing = FALSE, min.len = 2, unique = TRUE),
    "cohort_sizes must be a list of CohortSize (unique) objects only and be of length >= 2"
  )
  v$result()
}

# SafetyWindow ----

#' Internal Helper Functions for Validation of [`SafetyWindow`] Objects
#'
#' @description `r lifecycle::badge("stable")`
#'
#' These functions are only used internally to validate the format of an input
#' [`SafetyWindow`] or inherited classes and therefore not exported.
#'
#' @name v_safety_window
#' @param object (`SafetyWindow`)\cr object to validate.
#' @return A `character` vector with the validation failure messages,
#'   or `TRUE` in case validation passes.
NULL

#' @describeIn v_safety_window validates that the [`SafetyWindowSize`] object
#'   contains valid slots.
v_safety_window_size <- function(object) {
  v <- Validate()
  v$check(
    test_list(object@gap, types = "integer", any.missing = FALSE, min.len = 1),
    "gap must be a list of length >= 1 with integer vectors only"
  )
  v$check(
    all(sapply(object@gap, test_integer, lower = 0, any.missing = FALSE, min.len = 1)),
    "every element in gap list has to be an integer vector with non-negative and non-missing values"
  )
  pg_len <- length(object@gap)
  v$check(
    test_integer(
      object@size,
      lower = .Machine$double.xmin, any.missing = FALSE, len = pg_len, unique = TRUE, sorted = TRUE
    ),
    "size has to be an integer vector, of the same length as gap, with positive, unique and sorted non-missing values"
  )
  v$check(
    test_int(object@follow, lower = .Machine$double.xmin),
    "follow has to be a positive integer number"
  )
  v$check(
    test_int(object@follow_min, lower = .Machine$double.xmin),
    "follow_min has to be a positive integer number"
  )
  v$result()
}

#' @describeIn v_safety_window validates that the [`SafetyWindowConst`] object
#'   contains valid slots.
v_safety_window_const <- function(object) {
  v <- Validate()
  v$check(
    test_integer(object@gap, lower = 0, any.missing = FALSE),
    "gap has to be an integer vector with non-negative and non-missing elements"
  )
  v$check(
    test_int(object@follow, lower = .Machine$double.xmin),
    "follow has to be a positive integer number"
  )
  v$check(
    test_int(object@follow_min, lower = .Machine$double.xmin),
    "follow_min has to be a positive integer number"
  )
  v$result()
}

#' @describeIn v_next_best validates that the [`NextBestOrdinal`] object
#'   contains valid `grade` and standard `NextBest` rule.
v_next_best_ordinal <- function(object) {
  v <- Validate()
  v$check(
    test_integer(object@grade, lower = 1),
    "grade must be a positive integer"
  )
  v$check(
    test_class(object@rule, "NextBest"),
    "rule must be a NextBest object"
  )
  v$result()
}

#' @describeIn v_increments validates that the [`IncrementsOrdinal`] object
#'   contains valid `grade` and standard `Increments` rule.
v_increments_ordinal <- function(object) {
  v <- Validate()
  v$check(
    test_integer(object@grade, lower = 1),
    "grade must be a positive integer"
  )
  v$check(
    test_class(object@rule, "Increments"),
    "rule must be a Increments object"
  )
  v$result()
}

#' @describeIn v_increments validates that the [`CohortSizeOrdinal`] object
#'   contains valid `grade` and standard `CohortSize` rule.
v_cohort_size_ordinal <- function(object) {
  v <- Validate()
  v$check(
    test_integer(object@grade, lower = 1),
    "grade must be a positive integer"
  )
  v$check(
    test_class(object@rule, "CohortSize"),
    "rule must be a CohortSize object"
  )
  v$result()
}

# nolint start
#####################################################################################
## Author: Daniel Sabanes Bove [sabanesd *a*t* roche *.* com],
##         Wai Yin Yeung [ w *.* yeung1 *a*t* lancaster *.* ac *.* uk]
## Project: Object-oriented implementation of CRM designs
##
## Time-stamp: <[Simulations-methods.R] by DSB Fre 16/01/2015 13:41>
##
## Description:
## Methods for handling the simulations output.
##
## History:
## 19/02/2014   file creation
## 30/07/2014   added in methods for pseudo models simulations
###################################################################################


##' @include Simulations-class.R
##' @include helpers.R
{}


##' Plot simulations
##'
##' Summarize the simulations with plots
##'
##' This plot method can be applied to \code{\linkS4class{GeneralSimulations}}
##' objects in order to summarize them graphically. Possible \code{type}s of
##' plots at the moment are: \describe{ \item{trajectory}{Summary of the
##' trajectory of the simulated trials} \item{dosesTried}{Average proportions of
##' the doses tested in patients} } You can specify one or both of these in the
##' \code{type} argument.
##'
##' @param x the \code{\linkS4class{GeneralSimulations}} object we want
##' to plot from
##' @param y missing
##' @param type the type of plots you want to obtain.
##' @param \dots not used
##' @return A single \code{\link[ggplot2]{ggplot}} object if a single plot is
##' asked for, otherwise a \code{\link{gridExtra}{gTree}} object.
##'
##' @importFrom ggplot2 ggplot geom_step geom_bar aes xlab ylab
##' scale_linetype_manual
##' @importFrom gridExtra arrangeGrob
##'
##' @example examples/Simulations-method-plotSIMsingle.R
##' @export
##' @keywords methods
setMethod("plot",
  signature =
    signature(
      x = "GeneralSimulations",
      y = "missing"
    ),
  def =
    function(x,
             y,
             type =
               c(
                 "trajectory",
                 "dosesTried"
               ),
             ...) {
      ## which plots should be produced?
      type <- match.arg(type,
        several.ok = TRUE
      )
      stopifnot(length(type) > 0L)

      ## start the plot list
      plotList <- list()
      plotIndex <- 0L


      ## summary of the trajectories
      if ("trajectory" %in% type) {
        ## get a matrix of the simulated dose trajectories,
        ## where the rows correspond to the simulations and
        ## the columns to the patient index:

        ## If design with placebo, then exclude placebo Patients
        if (x@data[[1]]@placebo) {
          PL <- x@data[[1]]@doseGrid[1]
          simDoses <- lapply(
            x@data,
            function(y) {
              y@x[y@x != PL]
            }
          )
        } else {
          simDoses <- lapply(
            x@data,
            slot,
            "x"
          )
        }

        maxPatients <- max(sapply(simDoses, length))

        simDosesMat <- matrix(
          data = NA,
          nrow = length(simDoses),
          ncol = maxPatients
        )

        for (i in seq_along(simDoses))
        {
          simDosesMat[i, seq_along(simDoses[[i]])] <-
            simDoses[[i]]
        }


        ## extract statistics
        stats <- c(
          "Minimum",
          "Lower Quartile",
          "Median",
          "Upper Quartile",
          "Maximum"
        )
        traj.df <-
          data.frame(
            patient =
              rep(seq_len(maxPatients), each = 5L),
            Statistic =
              factor(
                rep(
                  stats,
                  maxPatients
                ),
                levels = stats
              ),
            traj =
              c(apply(simDosesMat, 2L, quantile,
                na.rm = TRUE
              ))
          )

        ## linetypes for the plot
        lt <- c(
          "Median" = 1,
          "Lower Quartile" = 2,
          "Upper Quartile" = 2,
          "Minimum" = 4,
          "Maximum" = 4
        )

        ## save the plot
        if (x@data[[1]]@placebo) {
          myTitle <- "Patient (placebo were excluded)"
        } else {
          myTitle <- "Patient"
        }
        plotList[[plotIndex <- plotIndex + 1L]] <-
          ggplot() +
          geom_step(
            aes(
              x = patient,
              y = traj,
              group = Statistic,
              linetype = Statistic
            ),
            size = 1.2, colour = "blue", data = traj.df
          ) +
          ## scale_linetype_manual(values=lt) +
          xlab(myTitle) +
          ylab("Dose Level")
      }

      ## average distribution of the doses tried
      if ("dosesTried" %in% type) {
        ## get the doses tried
        simDoses <- lapply(
          x@data,
          slot,
          "x"
        )

        ## get the dose distributions by trial
        doseDistributions <-
          sapply(
            simDoses,
            function(s) {
              if (length(s) > 0) {
                prop.table(table(factor(s, levels = x@data[[1]]@doseGrid)))
              } else {
                rep(0, length(x@data[[1]]@doseGrid))
              }
            }
          )

        ## derive the average dose distribution across trial
        ## simulations
        averageDoseDist <- rowMeans(doseDistributions)

        ## get in data frame shape
        dat <- data.frame(
          dose = as.numeric(names(averageDoseDist)),
          perc = averageDoseDist * 100
        )

        ## produce and save the plot
        plotList[[plotIndex <- plotIndex + 1L]] <-
          ggplot() +
          geom_bar(
            data = as.data.frame(dat),
            aes(x = dose, y = perc),
            stat = "identity",
            position = "identity",
            width = min(diff(x@data[[1]]@doseGrid)) / 2
          ) +
          xlab("Dose level") +
          ylab("Average proportion [%]")
      }
      ## then finally plot everything

      ## if there is only one plot
      if (identical(
        length(plotList),
        1L
      )) {
        ## just return it
        return(plotList[[1L]])
      } else {
        ## otherwise arrange them
        ret <- do.call(
          gridExtra::arrangeGrob,
          plotList
        )
        return(ret)
      }
    }
)


##' Plot dual-endpoint simulations
##'
##' This plot method can be applied to \code{\linkS4class{DualSimulations}}
##' objects in order to summarize them graphically. In addition to the standard
##' plot types, there is
##' \describe{
##' \item{sigma2W}{Plot a boxplot of the final biomarker variance estimates in
##' the simulated trials}
##' \item{rho}{Plot a boxplot of the final correlation estimates in
##' the simulated trials}
##' }
##'
##' @param x the \code{\linkS4class{DualSimulations}} object we want
##' to plot from
##' @param y missing
##' @param type the type of plots you want to obtain.
##' @param \dots not used
##' @return A single \code{\link[ggplot2]{ggplot}} object if a single plot is
##' asked for, otherwise a \code{\link{gridExtra}{gTree}} object.
##'
##' @importFrom ggplot2 qplot coord_flip scale_x_discrete
##' @importFrom gridExtra arrangeGrob
##'
##' @example examples/Simulations-method-plot-DualSimulations.R
##' @export
##' @keywords methods
setMethod("plot",
  signature =
    signature(
      x = "DualSimulations",
      y = "missing"
    ),
  def =
    function(x,
             y,
             type =
               c(
                 "trajectory",
                 "dosesTried",
                 "sigma2W",
                 "rho"
               ),
             ...) {
      ## start the plot list
      plotList <- list()
      plotIndex <- 0L

      ## which plots should be produced?
      type <- match.arg(type,
        several.ok = TRUE
      )
      stopifnot(length(type) > 0L)

      ## substract the specific plot types for
      ## dual-endpoint simulation results
      typeReduced <- setdiff(
        type,
        c("sigma2W", "rho")
      )

      ## are there more plots from general?
      moreFromGeneral <- (length(typeReduced) > 0)

      ## if so, then produce these plots
      if (moreFromGeneral) {
        genPlot <- callNextMethod(x = x, y = y, type = typeReduced)
      }

      ## now to the specific dual-endpoint plots:

      ## biomarker variance estimates boxplot
      if ("sigma2W" %in% type) {
        ## save the plot
        plotList[[plotIndex <- plotIndex + 1L]] <-
          qplot(factor(0),
            y = y, data = data.frame(y = x@sigma2w_est), geom = "boxplot",
            xlab = "", ylab = "Biomarker variance estimates"
          ) +
          coord_flip() + scale_x_discrete(breaks = NULL)
      }

      ## correlation estimates boxplot
      if ("rho" %in% type) {
        ## save the plot
        plotList[[plotIndex <- plotIndex + 1L]] <-
          qplot(factor(0),
            y = y, data = data.frame(y = x@rho_est), geom = "boxplot",
            xlab = "", ylab = "Correlation estimates"
          ) +
          coord_flip() + scale_x_discrete(breaks = NULL)
      }

      ## then finally plot everything
      if (identical(
        length(plotList),
        0L
      )) {
        return(genPlot)
      } else if (identical(
        length(plotList),
        1L
      )) {
        ret <- plotList[[1L]]
      } else {
        ret <- do.call(
          gridExtra::arrangeGrob,
          plotList
        )
      }

      if (moreFromGeneral) {
        ret <- gridExtra::arrangeGrob(genPlot, ret)
      }

      return(ret)
    }
)



##' Summarize the simulations, relative to a given truth
##'
##' @param object the \code{\linkS4class{GeneralSimulations}} object we want to
##' summarize
##' @param truth a function which takes as input a dose (vector) and returns the
##' true probability (vector) for toxicity
##' @param target the target toxicity interval (default: 20-35%) used for the
##' computations
##' @param \dots Additional arguments can be supplied here for \code{truth}
##' @return an object of class \code{\linkS4class{GeneralSimulationsSummary}}
##'
##' @export
##' @keywords methods
setMethod("summary",
  signature =
    signature(object = "GeneralSimulations"),
  def =
    function(object,
             truth,
             target = c(0.2, 0.35),
             ...) {
      ## extract dose grid
      doseGrid <- object@data[[1]]@doseGrid

      ## evaluate true toxicity at doseGrid
      trueTox <- truth(doseGrid, ...)

      ## find dose interval corresponding to target tox interval
      targetDoseInterval <-
        sapply(
          target,
          function(t) {
            ## we have to be careful because it might be
            ## that in the range of the dose grid, no
            ## doses can be found that match the target
            ## interval boundaries!
            ## In that case we want to return NA
            r <- try(
              uniroot(
                f = function(x) {
                  truth(x, ...) - t
                },
                interval =
                  range(doseGrid)
              )$root,
              silent = TRUE
            )
            if (inherits(r, "try-error")) {
              return(NA_real_)
            } else {
              return(r)
            }
          }
        )

      ## what are the levels above target interval?
      xAboveTarget <- which(trueTox > target[2])

      ## proportion of DLTs in a trial:
      if (object@data[[1]]@placebo) {
        if (sum(object@data[[1]]@x == doseGrid[1])) {
          propDLTs <- sapply(
            object@data,
            function(d) {
              tapply(
                d@y,
                factor(d@x == d@doseGrid[1],
                  labels = c("ACTV", "PLCB")
                ),
                mean
              )
            }
          )
        } else {
          propDLTs <- sapply(
            object@data,
            function(d) {
              c("ACTV" = mean(d@y), "PLCB" = NA)
            }
          )
        }
      } else {
        propDLTs <- sapply(
          object@data,
          function(d) {
            mean(d@y)
          }
        )
      }

      ## mean toxicity risk
      if (object@data[[1]]@placebo) {
        meanToxRisk <- sapply(
          object@data,
          function(d) {
            mean(trueTox[d@xLevel[d@xLevel != 1]])
          }
        )
      } else {
        meanToxRisk <- sapply(
          object@data,
          function(d) {
            mean(trueTox[d@xLevel])
          }
        )
      }

      ## doses selected for MTD
      doseSelected <- object@doses

      ## replace NA by 0
      doseSelected[is.na(doseSelected)] <- 0

      ## dose most often selected as MTD
      doseMostSelected <-
        as.numeric(names(which.max(table(doseSelected))))
      xMostSelected <-
        match_within_tolerance(doseMostSelected,
          table = doseGrid
        )

      ## observed toxicity rate at dose most often selected
      ## Note: this does not seem very useful!
      ## Reason: In case of a fine grid, few patients if any
      ## will have been treated at this dose.
      tmp <-
        sapply(
          object@data,
          function(d) {
            whichAtThisDose <- which(d@x == doseMostSelected)
            nAtThisDose <- length(whichAtThisDose)
            nDLTatThisDose <- sum(d@y[whichAtThisDose])
            return(c(
              nAtThisDose = nAtThisDose,
              nDLTatThisDose = nDLTatThisDose
            ))
          }
        )

      obsToxRateAtDoseMostSelected <-
        mean(tmp["nDLTatThisDose", ]) / mean(tmp["nAtThisDose", ])

      ## number of patients overall
      if (object@data[[1]]@placebo) {
        nObs <- sapply(
          object@data,
          function(x) {
            data.frame(
              n.ACTV = sum(x@xLevel != 1L),
              n.PLCB = sum(x@xLevel == 1L)
            )
          }
        )
        nObs <- matrix(unlist(nObs), dim(nObs))
      } else {
        nObs <- sapply(
          object@data,
          slot,
          "nObs"
        )
      }


      ## number of patients treated above target tox interval
      nAboveTarget <- sapply(
        object@data,
        function(d) {
          sum(d@xLevel %in% xAboveTarget)
        }
      )

      ## Proportion of trials selecting target MTD
      toxAtDoses <- truth(doseSelected, ...)
      propAtTarget <- mean((toxAtDoses > target[1]) &
        (toxAtDoses < target[2]))

      ## give back an object of class GeneralSimulationsSummary,
      ## for which we then define a print / plot method
      ret <-
        .GeneralSimulationsSummary(
          target = target,
          target_dose_interval = targetDoseInterval,
          nsim = length(object@data),
          prop_dlts = propDLTs,
          mean_tox_risk = meanToxRisk,
          dose_selected = doseSelected,
          dose_most_selected = doseMostSelected,
          obs_tox_rate_at_dose_most_selected = obsToxRateAtDoseMostSelected,
          n_obs = nObs,
          n_above_target = nAboveTarget,
          tox_at_doses_selected = toxAtDoses,
          prop_at_target = propAtTarget,
          dose_grid = doseGrid,
          placebo = object@data[[1]]@placebo
        )
      return(ret)
    }
)


##' Summarize the model-based design simulations, relative to a given truth
##'
##' @param object the \code{\linkS4class{Simulations}} object we want to
##' summarize
##' @param truth a function which takes as input a dose (vector) and returns the
##' true probability (vector) for toxicity
##' @param target the target toxicity interval (default: 20-35%) used for the
##' computations
##' @param \dots Additional arguments can be supplied here for \code{truth}
##' @return an object of class \code{\linkS4class{SimulationsSummary}}
##'
##' @example examples/Simulations-method-summary.R
##' @export
##' @keywords methods
setMethod("summary",
  signature =
    signature(object = "Simulations"),
  def =
    function(object,
             truth,
             target = c(0.2, 0.35),
             ...) {
      ## call the parent method
      start <- callNextMethod(
        object = object,
        truth = truth,
        target = target,
        ...
      )

      doseGrid <- object@data[[1]]@doseGrid

      ## dose level most often selected as MTD
      xMostSelected <-
        match_within_tolerance(start@dose_most_selected,
          table = doseGrid
        )

      ## fitted toxicity rate at dose most often selected
      fitAtDoseMostSelected <-
        sapply(
          object@fit,
          function(f) {
            f$middle[xMostSelected]
          }
        )

      ## mean fitted toxicity (average, lower and upper quantiles)
      ## at each dose level
      ## (this is required for plotting)
      meanFitMatrix <- sapply(
        object@fit,
        "[[",
        "middle"
      )
      meanFit <- list(
        truth =
          truth(doseGrid, ...),
        average =
          rowMeans(meanFitMatrix),
        lower =
          apply(
            meanFitMatrix,
            1L,
            quantile,
            0.025
          ),
        upper =
          apply(
            meanFitMatrix,
            1L,
            quantile,
            0.975
          )
      )

      ## give back an object of class SimulationsSummary,
      ## for which we then define a print / plot method
      ret <- .SimulationsSummary(
        start,
        stop_report = object@stop_report,
        additional_stats = object@additional_stats,
        fit_at_dose_most_selected = fitAtDoseMostSelected,
        mean_fit = meanFit
      )

      return(ret)
    }
)

##' Summarize the dual-endpoint design simulations, relative to given true
##' dose-toxicity and dose-biomarker curves
##'
##' @param object the \code{\linkS4class{DualSimulations}} object we want to
##' summarize
##' @param trueTox a function which takes as input a dose (vector) and returns the
##' true probability (vector) for toxicity.
##' @param trueBiomarker a function which takes as input a dose (vector) and
##' returns the true biomarker level (vector).
##' @param target the target toxicity interval (default: 20-35%) used for the
##' computations
##' @param \dots Additional arguments can be supplied here for \code{trueTox}
##' and \code{trueBiomarker}
##' @return an object of class \code{\linkS4class{DualSimulationsSummary}}
##'
##' @example examples/Simulations-method-summary-DualSimulations.R
##' @export
##' @keywords methods
setMethod("summary",
  signature =
    signature(object = "DualSimulations"),
  def =
    function(object,
             trueTox,
             trueBiomarker,
             target = c(0.2, 0.35),
             ...) {
      ## call the parent method
      start <- callNextMethod(
        object = object,
        truth = trueTox,
        target = target,
        ...
      )

      doseGrid <- object@data[[1]]@doseGrid

      ## dose level most often selected as MTD
      xMostSelected <-
        match_within_tolerance(start@dose_most_selected,
          table = doseGrid
        )

      ## fitted biomarker level at dose most often selected
      biomarkerFitAtDoseMostSelected <-
        sapply(
          object@fit_biomarker,
          function(f) {
            f$middleBiomarker[xMostSelected]
          }
        )

      ## mean fitted biomarker curve (average, lower and upper quantiles)
      ## at each dose level
      ## (this is required for plotting)
      meanBiomarkerFitMatrix <- sapply(
        object@fit_biomarker,
        "[[",
        "middleBiomarker"
      )
      meanBiomarkerFit <- list(
        truth =
          trueBiomarker(doseGrid, ...),
        average =
          rowMeans(meanBiomarkerFitMatrix),
        lower =
          apply(
            meanBiomarkerFitMatrix,
            1L,
            quantile,
            0.025
          ),
        upper =
          apply(
            meanBiomarkerFitMatrix,
            1L,
            quantile,
            0.975
          )
      )

      ## give back an object of class DualSimulationsSummary,
      ## for which we then define a print / plot method
      ret <- .DualSimulationsSummary(
        start,
        biomarkerFitAtDoseMostSelected = biomarkerFitAtDoseMostSelected,
        meanBiomarkerFit = meanBiomarkerFit
      )

      return(ret)
    }
)

##' A Reference Class to represent sequentially updated reporting objects.
##' @name Report
##' @field object The object from which to report
##' @field df the data frame to which columns are sequentially added
##' @field dfNames the names to which strings are sequentially added
Report <-
  setRefClass("Report",
    fields =
      list(
        object = "ANY",
        df = "data.frame",
        dfNames = "character"
      ),
    methods = list(
      dfSave =
        function(res, name) {
          df <<- cbind(df, res)
          dfNames <<- c(dfNames, name)
          return(res)
        },
      report =
        function(slotName,
                 description,
                 percent = TRUE,
                 digits = 0,
                 quantiles = c(0.1, 0.9),
                 subset = NULL,
                 doSum = FALSE) {
          vals <- slot(object, name = slotName)
          if (!is.null(subset)) {
            vals <- vals[subset, ]
          }
          if (doSum) {
            vals <- apply(vals, 2, sum)
          }
          if (percent) {
            unit <- " %"
            vals <- vals * 100
          } else {
            unit <- ""
          }

          res <- paste(round(mean(vals), digits),
            unit,
            " (",
            paste(
              round(
                quantile(vals,
                  quantiles,
                  na.rm = TRUE
                ),
                digits
              ),
              unit,
              collapse = ", ",
              sep = ""
            ),
            ")",
            sep = ""
          )

          ## print result to the buffer
          cat(
            description, ":",
            "mean",
            dfSave(res, slotName),
            "\n"
          )
        }
    )
  )


##' Show the summary of the simulations
##'
##' @param object the \code{\linkS4class{GeneralSimulationsSummary}} object we want
##' to print
##' @return invisibly returns a data frame of the results with one row and
##' appropriate column names
##'
##' @export
##' @keywords methods
setMethod("show",
  signature =
    signature(object = "GeneralSimulationsSummary"),
  def =
    function(object) {
      r <- Report$new(
        object = object,
        df =
          as.data.frame(matrix(
            nrow = 1,
            ncol = 0
          )),
        dfNames = character()
      )

      cat(
        "Summary of",
        r$dfSave(object@nsim, "nsim"),
        "simulations\n\n"
      )

      cat(
        "Target toxicity interval was",
        r$dfSave(
          paste(round(object@target * 100),
            collapse = ", "
          ),
          "target"
        ),
        "%\n"
      )
      cat(
        "Target dose interval corresponding to this was",
        r$dfSave(
          paste(round(object@target_dose_interval, 1),
            collapse = ", "
          ),
          "target_dose_interval"
        ),
        "\n"
      )
      cat(
        "Intervals are corresponding to",
        "10 and 90 % quantiles\n\n"
      )

      if (object@placebo) {
        r$report("n_obs",
          "Number of patients on placebo",
          percent = FALSE,
          subset = 2
        )
        r$report("n_obs",
          "Number of patients on active",
          percent = FALSE,
          subset = 1
        )
        r$report("n_obs",
          "Number of patients overall",
          percent = FALSE,
          doSum = TRUE
        )
      } else {
        r$report("n_obs",
          "Number of patients overall",
          percent = FALSE
        )
      }
      r$report("n_above_target",
        "Number of patients treated above target tox interval",
        percent = FALSE
      )

      if (object@placebo) {
        r$report("prop_dlts",
          "Proportions of DLTs in the trials for patients on placebo",
          subset = 2
        )
        r$report("prop_dlts",
          "Proportions of DLTs in the trials for patients on active",
          subset = 1
        )
      } else {
        r$report(
          "prop_dlts",
          "Proportions of DLTs in the trials"
        )
      }
      r$report(
        "mean_tox_risk",
        "Mean toxicity risks for the patients on active"
      )
      r$report("dose_selected",
        "Doses selected as MTD",
        percent = FALSE, digits = 1
      )
      r$report(
        "tox_at_doses_selected",
        "True toxicity at doses selected"
      )
      cat(
        "Proportion of trials selecting target MTD:",
        r$dfSave(
          object@prop_at_target * 100,
          "prop_at_target"
        ),
        "%\n"
      )
      cat(
        "Dose most often selected as MTD:",
        r$dfSave(
          object@dose_most_selected,
          "dose_most_selected"
        ),
        "\n"
      )
      cat(
        "Observed toxicity rate at dose most often selected:",
        r$dfSave(
          round(object@obs_tox_rate_at_dose_most_selected * 100),
          "obs_tox_rate_at_dose_most_selected"
        ),
        "%\n"
      )

      ## finally assign names to the df
      ## and return it invisibly
      names(r$df) <- r$dfNames
      invisible(r$df)
    }
)

##' Show the summary of the simulations
##'
##' @param object the \code{\linkS4class{SimulationsSummary}} object we want
##' to print
##' @return invisibly returns a data frame of the results with one row and
##' appropriate column names
##'
##' @example examples/Simulations-method-show-SimulationsSummary.R
##' @export
##' @keywords methods
setMethod("show",
  signature =
    signature(object = "SimulationsSummary"),
  def =
    function(object) {
      ## call the parent method
      df <- callNextMethod(object)
      dfNames <- names(df)

      ## start report object
      r <- Report$new(
        object = object,
        df = df,
        dfNames = dfNames
      )


      ## add one reporting line
      r$report(
        "fit_at_dose_most_selected",
        "Fitted toxicity rate at dose most often selected"
      )

      # Report results of additional statistics summary

      if (length(unlist(object@additional_stats)) > 0) {
        param_names <- h_summarize_add_stats(stats_list = object@additional_stats)[[1]]
        averages <- h_summarize_add_stats(stats_list = object@additional_stats)[[2]]

        for (i in seq_along(param_names)) {
          cat(param_names[i], ":", round(averages[[i]], 2), "\n")
        }
      }


      # Report individual stopping rules with non-<NA> labels.

      stop_pct_to_print <- h_calc_report_label_percentage(object@stop_report)

      if (length(stop_pct_to_print) > 0) {
        cat(
          "Stop reason triggered:\n",
          paste(names(stop_pct_to_print), ": ", round(stop_pct_to_print, 2), "%\n")
        )
      }

      ## and return the updated information
      names(r$df) <- r$dfNames
      invisible(r$df)
    }
)

##' Show the summary of the dual-endpoint simulations
##'
##' @param object the \code{\linkS4class{DualSimulationsSummary}} object we want
##' to print
##' @return invisibly returns a data frame of the results with one row and
##' appropriate column names
##'
##' @example examples/Simulations-method-show-DualSimulationsSummary.R
##' @export
##' @keywords methods
setMethod("show",
  signature =
    signature(object = "DualSimulationsSummary"),
  def =
    function(object) {
      ## call the parent method
      df <- callNextMethod(object)
      dfNames <- names(df)

      ## start report object
      r <- Report$new(
        object = object,
        df = df,
        dfNames = dfNames
      )

      ## add one reporting line
      r$report("biomarkerFitAtDoseMostSelected",
        "Fitted biomarker level at dose most often selected",
        percent = FALSE,
        digits = 1
      )

      ## and return the updated information
      names(r$df) <- r$dfNames
      invisible(r$df)
    }
)


##' Graphical display of the general simulation summary
##'
##' This plot method can be applied to
##' \code{\linkS4class{GeneralSimulationsSummary}} objects in order to
##' summarize them graphically. Possible \code{type}s of plots at the moment
##' are:
##'
##' \describe{
##' \item{nObs}{Distribution of the number of patients in the simulated trials}
##' \item{doseSelected}{Distribution of the final selected doses in the trials.
##' Note that this can include zero entries, meaning that the trial was stopped
##' because all doses in the dose grid appeared too toxic.}
##' \item{propDLTs}{Distribution of the proportion of patients with DLTs in the
##' trials}
##' \item{nAboveTarget}{Distribution of the number of patients treated at doses
##' which are above the target toxicity interval (as specified by the
##' \code{truth} and \code{target} arguments to
##' \code{\link{summary,GeneralSimulations-method}})}
##' }
##' You can specify any subset of these in the \code{type} argument.
##'
##' @param x the \code{\linkS4class{GeneralSimulationsSummary}} object we want
##' to plot from
##' @param y missing
##' @param type the types of plots you want to obtain.
##' @param \dots not used
##' @return A single \code{\link[ggplot2]{ggplot}} object if a single plot is
##' asked for, otherwise a \code{\link{gridExtra}{gTree}} object.
##'
##' @importFrom ggplot2 geom_histogram ggplot aes xlab ylab geom_line
##' scale_linetype_manual scale_colour_manual
##' @importFrom gridExtra arrangeGrob
##' @export
##' @keywords methods
setMethod("plot",
  signature =
    signature(
      x = "GeneralSimulationsSummary",
      y = "missing"
    ),
  def =
    function(x,
             y,
             type =
               c(
                 "nObs",
                 "doseSelected",
                 "propDLTs",
                 "nAboveTarget"
               ),
             ...) {
      ## which plots should be produced?
      type <- match.arg(type,
        several.ok = TRUE
      )
      stopifnot(length(type) > 0L)

      ## start the plot list
      plotList <- list()
      plotIndex <- 0L

      ## distribution of overall sample size
      if (x@placebo) {
        if ("nObs" %in% type) {
          plotList[[plotIndex <- plotIndex + 1L]] <-
            h_barplot_percentages(
              x = x@n_obs[2, ],
              description = "Number of patients on active in total"
            )
        }
      } else {
        if ("nObs" %in% type) {
          plotList[[plotIndex <- plotIndex + 1L]] <-
            h_barplot_percentages(
              x = x@n_obs,
              description = "Number of patients in total"
            )
        }
      }

      ## distribution of final MTD estimate
      if ("doseSelected" %in% type) {
        plotList[[plotIndex <- plotIndex + 1L]] <-
          h_barplot_percentages(
            x = x@dose_selected,
            description = "MTD estimate"
          )
      }

      ## distribution of proportion of DLTs
      if (x@placebo) {
        if ("propDLTs" %in% type) {
          plotList[[plotIndex <- plotIndex + 1L]] <-
            h_barplot_percentages(
              x = x@prop_dlts[1, ] * 100,
              description = "Proportion of DLTs [%] on active",
              xaxisround = 1
            )
        }
      } else {
        if ("propDLTs" %in% type) {
          plotList[[plotIndex <- plotIndex + 1L]] <-
            h_barplot_percentages(
              x = x@prop_dlts * 100,
              description = "Proportion of DLTs [%]",
              xaxisround = 1
            )
        }
      }

      ## distribution of number of patients treated at too much tox
      if ("nAboveTarget" %in% type) {
        plotList[[plotIndex <- plotIndex + 1L]] <-
          h_barplot_percentages(
            x = x@n_above_target,
            description = "Number of patients above target"
          )
      }

      ## first combine these small plots
      if (length(plotList)) {
        ret <-
          ## if there is only one plot
          if (identical(
            length(plotList),
            1L
          )) {
            ## just use that
            plotList[[1L]]
          } else {
            ## multiple plots in this case
            do.call(
              gridExtra::arrangeGrob,
              plotList
            )
          }
      }

      ## then return
      ret
    }
)


##' Plot summaries of the model-based design simulations
##'
##' Graphical display of the simulation summary
##'
##' This plot method can be applied to \code{\linkS4class{SimulationsSummary}}
##' objects in order to summarize them graphically. Possible \code{type} of
##' plots at the moment are those listed in
##' \code{\link{plot,GeneralSimulationsSummary,missing-method}} plus:
##' \describe{
##' \item{meanFit}{Plot showing the average fitted dose-toxicity curve across
##' the trials, together with 95% credible intervals, and comparison with the
##' assumed truth (as specified by the \code{truth} argument to
##' \code{\link{summary,Simulations-method}})}
##' }
##' You can specify any subset of these in the \code{type} argument.
##'
##' @param x the \code{\linkS4class{SimulationsSummary}} object we want
##' to plot from
##' @param y missing
##' @param type the types of plots you want to obtain.
##' @param \dots not used
##' @return A single \code{\link[ggplot2]{ggplot}} object if a single plot is
##' asked for, otherwise a \code{\link{gridExtra}{gTree}} object.
##'
##' @importFrom ggplot2 geom_histogram ggplot aes xlab ylab geom_line
##' scale_linetype_manual scale_colour_manual
##' @importFrom gridExtra arrangeGrob
##'
##' @example examples/Simulations-method-plot-SimulationsSummary.R
##' @export
##' @keywords methods
setMethod("plot",
  signature =
    signature(
      x = "SimulationsSummary",
      y = "missing"
    ),
  def =
    function(x,
             y,
             type =
               c(
                 "nObs",
                 "doseSelected",
                 "propDLTs",
                 "nAboveTarget",
                 "meanFit"
               ),
             ...) {
      ## which plots should be produced?
      type <- match.arg(type,
        several.ok = TRUE
      )
      stopifnot(length(type) > 0L)

      ## substract the specific plot types for model-based
      ## designs
      typeReduced <- setdiff(
        type,
        "meanFit"
      )

      ## are there more plots from general?
      moreFromGeneral <- (length(typeReduced) > 0)

      ## if so, then produce these plots
      if (moreFromGeneral) {
        ret <- callNextMethod(x = x, y = y, type = typeReduced)
      }

      ## is the meanFit plot requested?
      if ("meanFit" %in% type) {
        ## which types of lines do we have?
        linetype <- c(
          "True toxicity",
          "Average estimated toxicity",
          "95% interval for estimated toxicity"
        )

        ## create the data frame, with
        ## true tox, average estimated tox, and 95% (lower, upper)
        ## estimated tox (in percentage) stacked below each other
        dat <- data.frame(
          dose =
            rep(x@dose_grid, 4L),
          group =
            rep(1:4, each = length(x@dose_grid)),
          linetype =
            factor(
              rep(linetype[c(1, 2, 3, 3)],
                each = length(x@dose_grid)
              ),
              levels = linetype
            ),
          lines =
            unlist(x@mean_fit) * 100
        )

        ## linetypes for the plot
        lt <- c(
          "True toxicity" = 1,
          "Average estimated toxicity" = 1,
          "95% interval for estimated toxicity" = 2
        )

        ## colour for the plot
        col <- c(
          "True toxicity" = 1,
          "Average estimated toxicity" = 2,
          "95% interval for estimated toxicity" = 2
        )

        ## now create and save the plot
        thisPlot <- ggplot() +
          geom_line(
            aes(
              x = dose,
              y = lines,
              group = group,
              linetype = linetype,
              col = linetype
            ),
            data = dat
          )

        thisPlot <- thisPlot +
          scale_linetype_manual(values = lt) +
          scale_colour_manual(values = col) +
          xlab("Dose level") +
          ylab("Probability of DLT [%]")

        ## add this plot to the bottom
        ret <-
          if (moreFromGeneral) {
            gridExtra::arrangeGrob(ret, thisPlot)
          } else {
            thisPlot
          }
      }

      ## then finally plot everything
      ret
    }
)


##' Plot summaries of the dual-endpoint design simulations
##'
##' This plot method can be applied to \code{\linkS4class{DualSimulationsSummary}}
##' objects in order to summarize them graphically. Possible \code{type} of
##' plots at the moment are those listed in
##' \code{\link{plot,SimulationsSummary,missing-method}} plus:
##' \describe{
##' \item{meanBiomarkerFit}{Plot showing the average fitted dose-biomarker curve across
##' the trials, together with 95% credible intervals, and comparison with the
##' assumed truth (as specified by the \code{trueBiomarker} argument to
##' \code{\link{summary,DualSimulations-method}})}
##' }
##' You can specify any subset of these in the \code{type} argument.
##'
##' @param x the \code{\linkS4class{DualSimulationsSummary}} object we want
##' to plot from
##' @param y missing
##' @param type the types of plots you want to obtain.
##' @param \dots not used
##' @return A single \code{\link[ggplot2]{ggplot}} object if a single plot is
##' asked for, otherwise a \code{\link{gridExtra}{gTree}} object.
##'
##' @importFrom ggplot2 geom_histogram ggplot aes xlab ylab geom_line
##' scale_linetype_manual scale_colour_manual
##' @importFrom gridExtra arrangeGrob
##'
##' @example examples/Simulations-method-plot-DualSimulationsSummary.R
##' @export
##' @keywords methods
setMethod("plot",
  signature =
    signature(
      x = "DualSimulationsSummary",
      y = "missing"
    ),
  def =
    function(x,
             y,
             type =
               c(
                 "nObs",
                 "doseSelected",
                 "propDLTs",
                 "nAboveTarget",
                 "meanFit",
                 "meanBiomarkerFit"
               ),
             ...) {
      ## which plots should be produced?
      type <- match.arg(type,
        several.ok = TRUE
      )
      stopifnot(length(type) > 0L)

      ## substract the specific plot types for dual-endpoint
      ## designs
      typeReduced <- setdiff(
        type,
        "meanBiomarkerFit"
      )

      ## are there more plots from general?
      moreFromGeneral <- (length(typeReduced) > 0)

      ## if so, then produce these plots
      if (moreFromGeneral) {
        ret <- callNextMethod(x = x, y = y, type = typeReduced)
      }

      ## is the meanBiomarkerFit plot requested?
      if ("meanBiomarkerFit" %in% type) {
        ## which types of lines do we have?
        linetype <- c(
          "True biomarker",
          "Average estimated biomarker",
          "95% interval for estimated biomarker"
        )

        ## create the data frame, with
        ## true biomarker, average estimated biomarker, and 95% (lower, upper)
        ## estimated biomarker stacked below each other
        dat <- data.frame(
          dose =
            rep(x@dose_grid, 4L),
          group =
            rep(1:4, each = length(x@dose_grid)),
          linetype =
            factor(
              rep(linetype[c(1, 2, 3, 3)],
                each = length(x@dose_grid)
              ),
              levels = linetype
            ),
          lines =
            unlist(x@meanBiomarkerFit)
        )

        ## linetypes for the plot
        lt <- c(
          "True biomarker" = 1,
          "Average estimated biomarker" = 1,
          "95% interval for estimated biomarker" = 2
        )

        ## colour for the plot
        col <- c(
          "True biomarker" = 1,
          "Average estimated biomarker" = 2,
          "95% interval for estimated biomarker" = 2
        )

        ## now create and save the plot
        thisPlot <- ggplot() +
          geom_line(
            aes(
              x = dose,
              y = lines,
              group = group,
              linetype = linetype,
              col = linetype
            ),
            data = dat
          )

        thisPlot <- thisPlot +
          scale_linetype_manual(values = lt) +
          scale_colour_manual(values = col) +
          xlab("Dose level") +
          ylab("Biomarker level")

        ## add this plot to the bottom
        ret <-
          if (moreFromGeneral) {
            gridExtra::arrangeGrob(ret, thisPlot, heights = c(2 / 3, 1 / 3))
          } else {
            thisPlot
          }
      }

      ## then finally plot everything
      ret
    }
)


## --------------------------------------------------------------------------------------------------------
##' Summarize the simulations, relative to a given truth
##'
##' @param object the \code{\linkS4class{PseudoSimulations}} object we want to
##' summarize
##' @param truth a function which takes as input a dose (vector) and returns the
##' true probability (vector) for toxicity
##' @param targetEndOfTrial the target probability of DLE wanted to achieve at the end of a trial
##' @param targetDuringTrial the target probability of DLE wanted to achieve during a trial
##'
##' @param \dots Additional arguments can be supplied here for \code{truth}
##' @return an object of class \code{\linkS4class{PseudoSimulationsSummary}}
##'
##' @example examples/Simulations-method-summarySIMsingle.R
##' @export
##' @keywords methods
setMethod("summary",
  signature =
    signature(object = "PseudoSimulations"),
  def =
    function(object,
             truth,
             targetEndOfTrial = 0.3,
             targetDuringTrial = 0.35,
             ...) {
      ## extract dose grid
      doseGrid <- object@data[[1]]@doseGrid

      ## evaluate true DLE at doseGrid
      trueDLE <- truth(doseGrid)

      ## Inverse function of the truth function
      inverse <- function(f, lower = -100, upper = 100) {
        function(y) uniroot((function(x) f(x) - y), lower = lower, upper = upper)[1]
      }

      ## Function to obtain corresponsing dose level given target prob
      TD <- inverse(truth, 0, max(doseGrid))

      ## Find the dose corresponding to the target dose during trial
      targetDoseEndOfTrial <- as.numeric(TD(targetEndOfTrial))


      ## Find the dose corresponding to the target does end of trial
      targetDoseDuringTrial <- as.numeric(TD(targetDuringTrial))

      ## Find the dose at doseGrid corresponding to the above two quantities
      targetDoseEndOfTrialAtDoseGrid <- doseGrid[max(which(targetDoseEndOfTrial - doseGrid >= 0))]
      targetDoseDuringTrialAtDoseGrid <- doseGrid[max(which(targetDoseDuringTrial - doseGrid >= 0))]

      ## A summary for all TDtargetEndOfTrial dose obtained
      TDEOTSummary <- summary(object@FinalTDtargetEndOfTrialEstimates)

      FinalDoseRecSummary <- TDEOTSummary

      ratioTDEOTSummary <- summary(object@FinalTDEOTRatios)
      FinalRatioSummary <- ratioTDEOTSummary


      ## A summary for all TDtargetDuringTrial dose obtained
      TDDTSummary <- summary(object@FinalTDtargetDuringTrialEstimates)
      ## what are the levels above target End of Trial?
      xAboveTargetEndOfTrial <- which(trueDLE > targetEndOfTrial)

      ## what are the levels above target During Trial?
      xAboveTargetDuringTrial <- which(trueDLE > targetDuringTrial)


      ## proportion of DLEs in this trial
      propDLE <- sapply(
        object@data,
        function(d) {
          mean(d@y)
        }
      )
      ### mean toxicity risk
      meanToxRisk <- sapply(
        object@data,
        function(d) {
          mean(trueDLE[d@xLevel])
        }
      )

      ## doses selected for MTD
      doseSelected <- object@doses

      ## replace NA by 0
      doseSelected[is.na(doseSelected)] <- 0

      ## dose most often selected as MTD
      doseMostSelected <-
        as.numeric(names(which.max(table(doseSelected))))

      # doseRec <- doseMostSelected

      xMostSelected <-
        match_within_tolerance(doseMostSelected,
          table = doseGrid
        )

      ## observed toxicity rate at dose most often selected
      ## Note: this does not seem very useful!
      ## Reason: In case of a fine grid, few patients if any
      ## will have been treated at this dose.
      tmp <-
        sapply(
          object@data,
          function(d) {
            whichAtThisDose <- which(d@x == doseMostSelected)
            nAtThisDose <- length(whichAtThisDose)
            nDLTatThisDose <- sum(d@y[whichAtThisDose])
            return(c(
              nAtThisDose = nAtThisDose,
              nDLTatThisDose = nDLTatThisDose
            ))
          }
        )

      obsToxRateAtDoseMostSelected <-
        mean(tmp["nDLTatThisDose", ]) / mean(tmp["nAtThisDose", ])

      ## number of patients overall
      nObs <- sapply(
        object@data,
        slot,
        "nObs"
      )

      ## number of patients treated above target End of trial
      nAboveTargetEndOfTrial <- sapply(
        object@data,
        function(d) {
          sum(d@xLevel %in% xAboveTargetEndOfTrial)
        }
      )

      ## number of patients treated above target During trial
      nAboveTargetDuringTrial <- sapply(
        object@data,
        function(d) {
          sum(d@xLevel %in% xAboveTargetDuringTrial)
        }
      )

      toxAtDoses <- truth(doseSelected)


      ## Proportion of trials selecting target TDEndOfTrial and TDDuringTrial
      nsim <- length(object@data)

      propAtTargetEndOfTrial <- (length(which(object@doses == targetDoseEndOfTrialAtDoseGrid))) / nsim
      propAtTargetDuringTrial <- (length(which(object@doses == targetDoseDuringTrialAtDoseGrid))) / nsim

      RecDoseSummary <- TDEOTSummary

      ## fitted probDLE at dose most often selected
      ## find names in the fit list (check it is with or without samples)
      FitNames <- sapply(object@fit, names)


      if ("probDLE" %in% FitNames) {
        fitAtDoseMostSelected <- sapply(
          object@fit,
          function(f) {
            f$probDLE[xMostSelected]
          }
        )
        meanFitMatrix <- sapply(
          object@fit,
          "[[",
          "probDLE"
        )

        meanFit <- list(
          truth =
            truth(doseGrid),
          average = rowMeans(meanFitMatrix)
        )
      } else {
        ## fitted toxicity rate at dose most often selected
        fitAtDoseMostSelected <-
          sapply(
            object@fit,
            function(f) {
              f$middle[xMostSelected]
            }
          )

        ## mean fitted toxicity (average, lower and upper quantiles)
        ## at each dose level
        ## (this is required for plotting)
        meanFitMatrix <- sapply(
          object@fit,
          "[[",
          "middle"
        )
        meanFit <- list(
          truth =
            truth(doseGrid),
          average =
            rowMeans(meanFitMatrix),
          lower =
            apply(
              meanFitMatrix,
              1L,
              quantile,
              0.025
            ),
          upper =
            apply(
              meanFitMatrix,
              1L,
              quantile,
              0.975
            )
        )
      }

      ## give back an object of class GeneralSimulationsSummary,
      ## for which we then define a print / plot method
      ret <- .PseudoSimulationsSummary(
        targetEndOfTrial = targetEndOfTrial,
        targetDoseEndOfTrial = targetDoseEndOfTrial,
        targetDuringTrial = targetDuringTrial,
        targetDoseDuringTrial = targetDoseDuringTrial,
        targetDoseEndOfTrialAtDoseGrid = targetDoseEndOfTrialAtDoseGrid,
        targetDoseDuringTrialAtDoseGrid = targetDoseDuringTrialAtDoseGrid,
        TDEOTSummary = TDEOTSummary,
        TDDTSummary = TDDTSummary,
        FinalDoseRecSummary = FinalDoseRecSummary,
        ratioTDEOTSummary = ratioTDEOTSummary,
        FinalRatioSummary = FinalRatioSummary,
        nsim = length(object@data),
        propDLE = propDLE,
        meanToxRisk = meanToxRisk,
        doseSelected = doseSelected,
        doseMostSelected = doseMostSelected,
        # doseRec=doseRec,
        obsToxRateAtDoseMostSelected = obsToxRateAtDoseMostSelected,
        nObs = nObs,
        nAboveTargetEndOfTrial = nAboveTargetEndOfTrial,
        nAboveTargetDuringTrial = nAboveTargetDuringTrial,
        toxAtDosesSelected = toxAtDoses,
        propAtTargetEndOfTrial = propAtTargetEndOfTrial,
        propAtTargetDuringTrial = propAtTargetDuringTrial,
        doseGrid = doseGrid,
        fitAtDoseMostSelected = fitAtDoseMostSelected,
        stop_report = object@stop_report,
        meanFit = meanFit
      )

      return(ret)
    }
)
## ========================================================================================================
##' Show the summary of the simulations
##'
##' @param object the \code{\linkS4class{PseudoSimulationsSummary}} object we want
##' to print
##' @return invisibly returns a data frame of the results with one row and
##' appropriate column names
##'
##' @example examples/Simulations-method-showSIMsingle.R
##' @export
##' @keywords methods

setMethod("show",
  signature =
    signature(object = "PseudoSimulationsSummary"),
  def =
    function(object) {
      r <- Report$new(
        object = object,
        df =
          as.data.frame(matrix(
            nrow = 1,
            ncol = 0
          )),
        dfNames = character()
      )
      cat(
        "Summary of",
        r$dfSave(object@nsim, "nsim"),
        "simulations\n\n"
      )

      cat(
        "Target probability of DLE p(DLE) used at the end of a trial was",
        r$dfSave(
          object@targetEndOfTrial * 100,
          "targetEndOfTrial"
        ), "%\n"
      )

      cat(
        "The dose level corresponds to the target p(DLE) used at the end of a trial, TDEOT, was",
        r$dfSave(
          object@targetDoseEndOfTrial,
          "targetDoseEndOfTrial"
        ), "\n"
      )
      cat(
        "TDEOT at dose Grid was",
        r$dfSave(
          object@targetDoseEndOfTrialAtDoseGrid,
          "targetDoseEndOfTrialAtDoseGrid"
        ), "\n"
      )

      cat(
        "Target p(DLE) used during a trial was",
        r$dfSave(
          object@targetDuringTrial * 100,
          "targetDuringTrial"
        ), "%\n"
      )

      cat(
        "The dose level corresponds to the target p(DLE) used during a trial, TDDT, was",
        r$dfSave(
          object@targetDoseDuringTrial,
          "targetDoseDuringTrial"
        ), "\n"
      )

      cat(
        "TDDT at dose Grid was",
        r$dfSave(
          object@targetDoseDuringTrialAtDoseGrid,
          "targetDoseDuringTrialAtDoseGrid"
        ), "\n"
      )

      r$report("nObs",
        "Number of patients overall",
        percent = FALSE
      )
      r$report("nAboveTargetEndOfTrial",
        "Number of patients treated above the target p(DLE) used at the end of a trial",
        percent = FALSE
      )

      r$report("nAboveTargetDuringTrial",
        "Number of patients treated above the target p(DLE) used during a trial",
        percent = FALSE
      )

      r$report(
        "propDLE",
        "Proportions of observed DLT in the trials"
      )
      r$report(
        "meanToxRisk",
        "Mean toxicity risks for the patients"
      )
      r$report("doseSelected",
        "Doses selected as TDEOT",
        percent = FALSE, digits = 1
      )
      # r$report("doseRec",
      #         "Doses to recommend to subsequent study",
      #         percent=FALSE, digits=1)

      r$report(
        "toxAtDosesSelected",
        "True toxicity at TDEOT"
      )

      cat(
        "Proportion of trials selecting the TDEOT:",
        r$dfSave(
          object@propAtTargetEndOfTrial * 100,
          "percentAtTarget"
        ),
        "%\n"
      )


      cat(
        "Proportion of trials selecting the TDDT:",
        r$dfSave(
          object@propAtTargetDuringTrial * 100,
          "percentAtTarget"
        ),
        "%\n"
      )

      cat(
        "Dose most often selected as TDEOT:",
        r$dfSave(
          object@doseMostSelected,
          "doseMostSelected"
        ),
        "\n"
      )
      cat(
        "Observed toxicity rate at dose most often selected:",
        r$dfSave(
          round(object@obsToxRateAtDoseMostSelected * 100),
          "obsToxRateAtDoseMostSelected"
        ),
        "%\n"
      )
      r$report(
        "fitAtDoseMostSelected",
        "Fitted probabilities of DLE at dose most often selected"
      )

      TDEOTSum <- object@TDEOTSummary

      r$dfSave(as.numeric(TDEOTSum[1]), "TDEOTMin")
      r$dfSave(as.numeric(TDEOTSum[2]), "TDEOTlower")
      r$dfSave(as.numeric(TDEOTSum[3]), "TDEOTMedian")
      r$dfSave(as.numeric(TDEOTSum[4]), "TDEOTMean")
      r$dfSave(as.numeric(TDEOTSum[5]), "TDEOTUpper")
      r$dfSave(as.numeric(TDEOTSum[6]), "TDEOTMax")

      cat(
        "The summary table of the final TDEOT across all simulations\n",
        capture.output(TDEOTSum)[1], "\n",
        capture.output(TDEOTSum)[2], "\n"
      )

      ratioTDEOTSum <- object@ratioTDEOTSummary

      r$dfSave(as.numeric(ratioTDEOTSum[1]), "ratioTDEOTMin")
      r$dfSave(as.numeric(ratioTDEOTSum[2]), "ratioTDEOTlower")
      r$dfSave(as.numeric(ratioTDEOTSum[3]), "ratioTDEOTMedian")
      r$dfSave(as.numeric(ratioTDEOTSum[4]), "ratioTDEOTMean")
      r$dfSave(as.numeric(ratioTDEOTSum[5]), "ratioTDEOTUpper")
      r$dfSave(as.numeric(ratioTDEOTSum[6]), "ratioTDEOTMax")

      cat(
        "The summary table of the final ratios of the TDEOT across all simulations\n",
        capture.output(ratioTDEOTSum)[1], "\n",
        capture.output(ratioTDEOTSum)[2], "\n"
      )

      TDDTSum <- object@TDDTSummary

      r$dfSave(as.numeric(TDDTSum[1]), "TDDTMin")
      r$dfSave(as.numeric(TDDTSum[2]), "TDDTlower")
      r$dfSave(as.numeric(TDDTSum[3]), "TDDTMedian")
      r$dfSave(as.numeric(TDDTSum[4]), "TDDTMean")
      r$dfSave(as.numeric(TDDTSum[5]), "TDDTUpper")
      r$dfSave(as.numeric(TDDTSum[6]), "TDDTMax")

      cat(
        "The summary table of the final TDDT across all simulations\n",
        capture.output(TDDTSum)[1], "\n",
        capture.output(TDDTSum)[2], "\n"
      )

      FinalDoseRecSum <- object@FinalDoseRecSummary

      r$dfSave(as.numeric(FinalDoseRecSum[1]), "FinalDoseRecMin")
      r$dfSave(as.numeric(FinalDoseRecSum[2]), "FinalDoseReclower")
      r$dfSave(as.numeric(FinalDoseRecSum[3]), "FinalDoseRecMedian")
      r$dfSave(as.numeric(FinalDoseRecSum[4]), "FinalDoseRecMean")
      r$dfSave(as.numeric(FinalDoseRecSum[5]), "FinalDoseRecUpper")
      r$dfSave(as.numeric(FinalDoseRecSum[6]), "FinalDoseRecMax")

      cat(
        "The summary table of dose levels, the optimal dose\n to recommend for subsequent study across all simulations\n",
        capture.output(FinalDoseRecSum)[1], "\n",
        capture.output(FinalDoseRecSum)[2], "\n"
      )


      FinalratioSum <- object@FinalRatioSummary

      r$dfSave(as.numeric(FinalratioSum[1]), "FinalratioMin")
      r$dfSave(as.numeric(FinalratioSum[2]), "Finalratiolower")
      r$dfSave(as.numeric(FinalratioSum[3]), "FinalratioMedian")
      r$dfSave(as.numeric(FinalratioSum[4]), "FinalratioMean")
      r$dfSave(as.numeric(FinalratioSum[5]), "FinalratioUpper")
      r$dfSave(as.numeric(FinalratioSum[6]), "FinalratioMax")

      cat(
        "The summary table of the final ratios of the optimal dose for stopping across
                  all simulations\n",
        capture.output(FinalratioSum)[1], "\n",
        capture.output(FinalratioSum)[2], "\n\n"
      )

      # Report individual stopping rules with non-<NA> labels.

      stop_pct_to_print <- h_calc_report_label_percentage(object@stop_report)

      if (length(stop_pct_to_print) > 0) {
        cat(
          "Stop reason triggered:\n",
          paste(names(stop_pct_to_print), ": ", stop_pct_to_print, "%\n")
        )
      }

      ## finally assign names to the df
      ## and return it invisibly
      names(r$df) <- r$dfNames
      invisible(r$df)
    }
)
## -------------------------------------------------------------------------------------------
##' Plot summaries of the pseudo simulations
##'
##' Graphical display of the simulation summary
##'
##' This plot method can be applied to \code{\linkS4class{PseudoSimulationsSummary}}
##' objects in order to summarize them graphically. This can be used when only DLE responses are involved
##' in the simulations. This also applied to results with or without samples generated during the simulations
##'
##' @param x the \code{\linkS4class{PseudoSimulationsSummary}} object we want
##' to plot from
##' @param y missing
##' @param type the types of plots you want to obtain.
##' @param \dots not used
##' @return A single \code{\link[ggplot2]{ggplot}} object if a single plot is
##' asked for, otherwise a \code{\link{gridExtra}{gTree}} object.
##'
##' @importFrom ggplot2 geom_histogram ggplot aes xlab ylab geom_line
##' scale_linetype_manual scale_colour_manual
##' @importFrom gridExtra arrangeGrob
##'
##' @example examples/Simulations-method-plotSUMsingle.R
##' @export
##' @keywords methods
##'

setMethod("plot",
  signature =
    signature(
      x = "PseudoSimulationsSummary",
      y = "missing"
    ),
  def =
    function(x,
             y,
             type =
               c(
                 "nObs",
                 "doseSelected",
                 "propDLE",
                 "nAboveTargetEndOfTrial",
                 "meanFit"
               ),
             ...) {
      ## which plots should be produced?
      type <- match.arg(type,
        several.ok = TRUE
      )
      stopifnot(length(type) > 0L)

      ## start the plot list
      plotList <- list()
      plotIndex <- 0L

      ## distribution of overall sample size
      if ("nObs" %in% type) {
        plotList[[plotIndex <- plotIndex + 1L]] <-
          h_barplot_percentages(
            x = x@nObs,
            description = "Number of patients in total"
          )
      }

      ## distribution of final MTD estimate
      if ("doseSelected" %in% type) {
        plotList[[plotIndex <- plotIndex + 1L]] <-
          h_barplot_percentages(
            x = x@doseSelected,
            description = "MTD estimate"
          )
      }

      ## distribution of proportion of DLTs
      if ("propDLE" %in% type) {
        plotList[[plotIndex <- plotIndex + 1L]] <-
          h_barplot_percentages(
            x = x@propDLE * 100,
            description = "Proportion of DLE [%]",
            xaxisround = 1
          )
      }

      ## distribution of number of patients treated at too much tox
      if ("nAboveTargetEndOfTrial" %in% type) {
        plotList[[plotIndex <- plotIndex + 1L]] <-
          h_barplot_percentages(
            x = x@nAboveTargetEndOfTrial,
            description = "Number of patients above target"
          )
      }


      ## first combine these small plots
      if (length(plotList)) {
        ret <-
          ## if there is only one plot
          if (identical(
            length(plotList),
            1L
          )) {
            ## just use that
            plotList[[1L]]
          } else {
            ## multiple plots in this case
            do.call(
              gridExtra::arrangeGrob,
              plotList
            )
          }
      }

      ## the meanFit plot

      if ("meanFit" %in% type) { ## Find if DLE samples are generated in the simulations
        ## by checking if there the lower limits of the 95% Credibility
        ## interval are calculated
        if (!is.null(x@meanFit$lower)) {
          ## which types of lines do we have?
          linetype <- c(
            "True toxicity",
            "Average estimated toxicity",
            "95% interval for estimated toxicity"
          )
          ## create the data frame, with
          ## true tox, average estimated tox, and 95% (lower, upper)
          ## estimated tox (in percentage) stacked below each other
          dat <- data.frame(
            dose =
              rep(x@doseGrid, 4L),
            group =
              rep(1:4, each = length(x@doseGrid)),
            linetype =
              factor(
                rep(linetype[c(1, 2, 3, 3)],
                  each = length(x@doseGrid)
                ),
                levels = linetype
              ),
            lines =
              unlist(x@meanFit) * 100
          )

          ## linetypes for the plot
          lt <- c(
            "True toxicity" = 1,
            "Average estimated toxicity" = 1,
            "95% interval for estimated toxicity" = 2
          )

          ## colour for the plot
          col <- c(
            "True toxicity" = 1,
            "Average estimated toxicity" = 2,
            "95% interval for estimated toxicity" = 2
          )

          ## now create and save the plot
          thisPlot <- ggplot() +
            geom_line(
              aes(
                x = dose,
                y = lines,
                group = group,
                linetype = linetype,
                col = linetype
              ),
              data = dat
            )

          thisPlot <- thisPlot +
            scale_linetype_manual(values = lt) +
            scale_colour_manual(values = col) +
            xlab("Dose level") +
            ylab("Probability of DLE [%]")
        } else {
          ## which types of lines do we have?
          linetype <- c(
            "True toxicity",
            "Average estimated toxicity"
          )

          ## create the data frame, with
          ## true tox, average estimated tox
          ## estimated tox (in percentage) stacked below each other
          dat <- data.frame(
            dose =
              rep(x@doseGrid, 2L),
            group =
              rep(1:2, each = length(x@doseGrid)),
            linetype =
              factor(
                rep(linetype[c(1, 2)],
                  each = length(x@doseGrid)
                ),
                levels = linetype
              ),
            lines =
              unlist(x@meanFit) * 100
          )

          ## linetypes for the plot
          lt <- c(
            "True toxicity" = 1,
            "Average estimated toxicity" = 1
          )

          ## colour for the plot
          col <- c(
            "True toxicity" = 1,
            "Average estimated toxicity" = 2
          )

          ## now create and save the plot
          thisPlot <- ggplot() +
            geom_line(
              aes(
                x = dose,
                y = lines,
                group = group,
                linetype = linetype,
                col = linetype
              ),
              data = dat
            )

          thisPlot <- thisPlot +
            scale_linetype_manual(values = lt) +
            scale_colour_manual(values = col) +
            xlab("Dose level") +
            ylab("Probability of DLE [%]")
        }
      }


      ## then add this plot at the bottom
      ret <- gridExtra::arrangeGrob(ret, thisPlot)
      ret
    }
)
## --------------------------------------------------------------------------------------
##' Plot simulations
##'
##' Summarize the simulations with plots
##'
##' This plot method can be applied to \code{\linkS4class{PseudoDualSimulations}}
##' objects in order to summarize them graphically. Possible \code{type}s of
##' plots at the moment are: \describe{ \item{trajectory}{Summary of the
##' trajectory of the simulated trials} \item{dosesTried}{Average proportions of
##' the doses tested in patients} \item{sigma2}{The variance of the efficacy responses}}
##' You can specify one or both of these in the
##' \code{type} argument.
##'
##' @param x the \code{\linkS4class{PseudoDualSimulations}} object we want
##' to plot from
##' @param y missing
##' @param type the type of plots you want to obtain.
##' @param \dots not used
##' @return A single \code{\link[ggplot2]{ggplot}} object if a single plot is
##' asked for, otherwise a \code{\link{gridExtra}{gTree}} object.
##'
##' @importFrom ggplot2 ggplot geom_step geom_bar aes xlab ylab
##' scale_linetype_manual
##' @importFrom gridExtra arrangeGrob
##'
##' @example examples/Simulations-method-plotSIMDual.R
##' @export
##' @keywords methods
setMethod("plot",
  signature =
    signature(
      x = "PseudoDualSimulations",
      y = "missing"
    ),
  def =
    function(x,
             y,
             type =
               c(
                 "trajectory",
                 "dosesTried",
                 "sigma2"
               ),
             ...) {
      ## start the plot list
      plotList <- list()
      plotIndex <- 0L

      ## which plots should be produced?
      type <- match.arg(type,
        several.ok = TRUE
      )
      stopifnot(length(type) > 0L)

      ## substract the specific plot types for
      ## dual-endpoint simulation results
      typeReduced <- setdiff(
        type,
        "sigma2"
      )

      ## are there more plots from general?
      moreFromGeneral <- (length(typeReduced) > 0)

      ## if so, then produce these plots
      if (moreFromGeneral) {
        genPlot <- callNextMethod(x = x, y = y, type = typeReduced)
      }

      ## now to the specific dual-endpoint plots:

      ## Efficacy variance estimates boxplot
      if ("sigma2" %in% type) {
        ## save the plot
        plotList[[plotIndex <- plotIndex + 1L]] <-
          qplot(factor(0),
            y = y, data = data.frame(y = x@sigma2est), geom = "boxplot",
            xlab = "", ylab = "Efficacy variance estimates"
          ) +
          coord_flip() + scale_x_discrete(breaks = NULL)
      }


      ## then finally plot everything
      if (identical(
        length(plotList),
        0L
      )) {
        return(genPlot)
      } else if (identical(
        length(plotList),
        1L
      )) {
        ret <- plotList[[1L]]
      } else {
        ret <- do.call(
          gridExtra::arrangeGrob,
          plotList
        )
      }

      if (moreFromGeneral) {
        ret <- gridExtra::arrangeGrob(genPlot, ret, heights = c(2 / 3, 1 / 3))
      }

      return(ret)
    }
)
## ---------------------------------------------------------------------------------
##'
##' This plot method can be applied to \code{\linkS4class{PseudoDualFlexiSimulations}}
##' objects in order to summarize them graphically. Possible \code{type}s of
##' plots at the moment are: \describe{ \item{trajectory}{Summary of the
##' trajectory of the simulated trials} \item{dosesTried}{Average proportions of
##' the doses tested in patients} \item{sigma2}{The variance of the efficacy responses}
##' \item{sigma2betaW}{The variance of the random walk model}}
##' You can specify one or both of these in the
##' \code{type} argument.
##'
##' @param x the \code{\linkS4class{PseudoDualFlexiSimulations}} object we want
##' to plot from
##' @param y missing
##' @param type the type of plots you want to obtain.
##' @param \dots not used
##' @return A single \code{\link[ggplot2]{ggplot}} object if a single plot is
##' asked for, otherwise a \code{\link{gridExtra}{gTree}} object.
##'
##' @importFrom ggplot2 ggplot geom_step geom_bar aes xlab ylab
##' scale_linetype_manual
##' @importFrom gridExtra arrangeGrob
##'
##' @example examples/Simulations-method-plotSIMDualFlexi.R
##' @export
##' @keywords methods
setMethod("plot",
  signature =
    signature(
      x = "PseudoDualFlexiSimulations",
      y = "missing"
    ),
  def =
    function(x,
             y,
             type =
               c(
                 "trajectory",
                 "dosesTried",
                 "sigma2",
                 "sigma2betaW"
               ),
             ...) {
      ## start the plot list
      plotList <- list()
      plotIndex <- 0L

      ## which plots should be produced?
      type <- match.arg(type,
        several.ok = TRUE
      )
      stopifnot(length(type) > 0L)

      ## substract the specific plot types for
      ## dual-endpoint simulation results
      typeReduced <- setdiff(type, "sigma2betaW")

      ## are there more plots from general?
      moreFromGeneral <- (length(typeReduced) > 0)

      ## if so, then produce these plots
      if (moreFromGeneral) {
        genPlot <- callNextMethod(x = x, y = y, type = typeReduced)
      }

      ## now to the specific dual-endpoint plots:
      ## random walk model variance estimates boxplot

      if ("sigma2betaW" %in% type) {
        ## save the plot
        plotList[[plotIndex <- plotIndex + 1L]] <-
          qplot(factor(0),
            y = y, data = data.frame(y = x@sigma2betaWest), geom = "boxplot",
            xlab = "", ylab = "Random walk model variance estimates"
          ) +
          coord_flip() + scale_x_discrete(breaks = NULL)
      }

      ## then finally plot everything
      if (identical(
        length(plotList),
        0L
      )) {
        return(genPlot)
      } else if (identical(
        length(plotList),
        1L
      )) {
        ret <- plotList[[1L]]
      } else {
        ret <- do.call(
          gridExtra::arrangeGrob,
          plotList
        )
      }

      if (moreFromGeneral) {
        ret <- gridExtra::arrangeGrob(genPlot, ret, heights = c(2 / 3, 1 / 3))
      }

      return(ret)
    }
)

## -----------------------------------------------------------------------------------------
##' Summary for Pseudo Dual responses simulations, relative to a given pseudo DLE and efficacy model
##' (except the EffFlexi class model)
##'
##' @param object the \code{\linkS4class{PseudoDualSimulations}} object we want to summarize
##' @param trueDLE a function which takes as input a dose (vector) and returns the true probability (vector)
##' of DLE
##' @param trueEff a function which takes as input a dose (vector) and returns the mean efficacy value(s) (vector).
##' @param targetEndOfTrial the target probability of DLE that are used at the end of a trial. Default at 0.3.
##' @param targetDuringTrial the target probability of DLE that are used during the trial. Default at 0.35.
##' @param \dots Additional arguments can be supplied here for \code{trueDLE} and \code{trueEff}
##' @return an object of class \code{\linkS4class{PseudoDualSimulationsSummary}}
##'
##' @example examples/Simulations-method-summarySIMDual.R
##' @export
##' @keywords methods
setMethod("summary",
  signature =
    signature(object = "PseudoDualSimulations"),
  def =
    function(object,
             trueDLE,
             trueEff,
             targetEndOfTrial = 0.3,
             targetDuringTrial = 0.35,
             ...) {
      ## call the parent method
      start <- callNextMethod(
        object = object,
        truth = trueDLE,
        targetEndOfTrial = targetEndOfTrial,
        targetDuringTrial = targetDuringTrial,
        ...
      )
      doseGrid <- object@data[[1]]@doseGrid

      ## ## dose level most often selected as MTD (TDtargetEnd of Trial)
      xMostSelected <-
        match_within_tolerance(start@doseMostSelected,
          table = doseGrid
        )

      ## check if true Eff is a function
      ## check if special case applies
      isTrueEffFx <- is.function(trueEff)

      TDtargetEndOfTrial <- start@targetDoseEndOfTrial


      if (isTrueEffFx) {
        negtrueGainfn <- function(dose) {
          return(-(trueEff(dose)) / (1 + (trueDLE(dose) / (1 - trueDLE(dose)))))
        }
        Gstar <- optim(exp(1), negtrueGainfn, method = "BFGS")$par
        maxGainValue <- -(optim(exp(1), negtrueGainfn, method = "BFGS")$value)
        GstarAtDoseGrid <- doseGrid[max(which(Gstar - doseGrid >= 0))]
      } else {
        trueGain <- (trueEff) / (1 + (trueDLE(doseGrid) / (1 - trueDLE(doseGrid))))
        maxGainValue <- max(trueGain)
        Gstar <- doseGrid[which.max(trueGain)]
        GstarAtDoseGrid <- Gstar
      }

      ## A summary for all final Gstar obtained
      GstarSummary <- summary(object@FinalGstarEstimates)
      ratioGstarSummary <- summary(object@FinalGstarRatios)

      FinalDoseRecSummary <- summary(object@FinalOptimalDose)
      FinalRatioSummary <- summary(object@FinalRatios)



      ## find names in the fit efficacy list (check it is with or without samples)
      FitNames <- sapply(object@fitEff, names)
      if ("ExpEff" %in% FitNames) {
        ## fitted efficacy level at dose most often selected
        EffFitAtDoseMostSelected <- sapply(
          object@fitEff,
          function(f) {
            f$ExpEff[xMostSelected]
          }
        )
        meanEffFitMatrix <- sapply(
          object@fitEff,
          "[[",
          "ExpEff"
        )

        meanEffFit <- list(
          truth =
            trueEff(doseGrid),
          average = rowMeans(meanEffFitMatrix)
        )
      } else { ## fitted efficacy level at dose most often selected
        EffFitAtDoseMostSelected <-
          sapply(
            object@fitEff,
            function(f) {
              f$middle[xMostSelected]
            }
          )

        ## mean fitted  curve (average, lower and upper quantiles)
        ## at each dose level
        ## (this is required for plotting)
        meanEffFitMatrix <- sapply(
          object@fitEff,
          "[[",
          "middle"
        )

        ## check if special case applies

        if (isTrueEffFx) {
          TRUTHeff <- trueEff(doseGrid)
        } else {
          TRUTHeff <- trueEff
        }

        meanEffFit <- list(
          truth =
            TRUTHeff,
          average =
            rowMeans(meanEffFitMatrix),
          lower =
            apply(
              meanEffFitMatrix,
              1L,
              quantile,
              0.025
            ),
          upper =
            apply(
              meanEffFitMatrix,
              1L,
              quantile,
              0.975
            )
        )
      }

      ## give back an object of class PseudoDualSimulationsSummary,
      ## for which we then define a print / plot method
      ret <- .PseudoDualSimulationsSummary(
        start,
        targetGstar = Gstar,
        targetGstarAtDoseGrid = GstarAtDoseGrid,
        GstarSummary = GstarSummary,
        ratioGstarSummary = ratioGstarSummary,
        FinalDoseRecSummary = FinalDoseRecSummary,
        FinalRatioSummary = FinalRatioSummary,
        EffFitAtDoseMostSelected = EffFitAtDoseMostSelected,
        meanEffFit = meanEffFit,
        stop_report = object@stop_report
      )

      return(ret)
    }
)
## --------------------------------------------------------------------------------------------------
##' Summary for Pseudo Dual responses simulations given a pseudo DLE model and the Flexible efficacy model.
##'
##' @param object the \code{\linkS4class{PseudoDualFlexiSimulations}} object we want to summarize
##' @param trueDLE a function which takes as input a dose (vector) and returns the true probability of DLE (vector)
##' @param trueEff a vector which takes as input the true mean efficacy values at all dose levels (in order)
##' @param targetEndOfTrial the target probability of DLE that are used at the end of a trial. Default at 0.3.
##' @param targetDuringTrial the target probability of DLE that are used during the trial. Default at 0.35.
##' @param \dots Additional arguments can be supplied here for \code{trueDLE} and \code{trueEff}
##' @return an object of class \code{\linkS4class{PseudoDualSimulationsSummary}}
##'
##' @example examples/Simulations-method-summarySIMDualFlexi.R
##' @export
##' @keywords methods
setMethod("summary",
  signature =
    signature(object = "PseudoDualFlexiSimulations"),
  def =
    function(object,
             trueDLE,
             trueEff,
             targetEndOfTrial = 0.3,
             targetDuringTrial = 0.35,
             ...) {
      ## call the parent method
      start <- callNextMethod(
        object = object,
        trueDLE = trueDLE,
        trueEff = trueEff,
        targetEndOfTrial = targetEndOfTrial,
        targetDuringTrial = targetDuringTrial,
        ...
      )


      ## give back an object of class PseudoDualSimulationsSummary,
      ## for which we then define a print / plot method
      ret <- .PseudoDualSimulationsSummary(start)

      return(ret)
    }
)

## ----------------------------------------------------------------------------------------
##' Show the summary of Pseudo Dual simulations summary
##'
##' @param object the \code{\linkS4class{PseudoDualSimulationsSummary}} object we want to print
##' @return invisibly returns a data frame of the results with one row and appropriate column names
##'
##'
##' @example examples/Simulations-method-showSIMDual.R
##' @export
##' @keywords methods
setMethod("show",
  signature =
    signature(object = "PseudoDualSimulationsSummary"),
  def =
    function(object) {
      ## call the parent method
      df <- callNextMethod(object)
      dfNames <- names(df)

      ## start report object
      r <- Report$new(
        object = object,
        df = df,
        dfNames = dfNames
      )

      ## add three reporting lines
      cat(
        "Target Gstar, the dose which gives the maximum gain value was",
        r$dfSave(
          object@targetGstar,
          "targetGstar"
        ), "\n"
      )
      cat(
        "Target Gstar at dose Grid was",
        r$dfSave(
          object@targetGstarAtDoseGrid,
          "targetGstarAtDoseGrid"
        ), "\n"
      )

      GstarSum <- object@GstarSummary

      r$dfSave(as.numeric(GstarSum[1]), "GstarMin")
      r$dfSave(as.numeric(GstarSum[2]), "Gstarlower")
      r$dfSave(as.numeric(GstarSum[3]), "GstarMedian")
      r$dfSave(as.numeric(GstarSum[4]), "GstarMean")
      r$dfSave(as.numeric(GstarSum[5]), "GstarUpper")
      r$dfSave(as.numeric(GstarSum[6]), "GstarMax")

      cat(
        "The summary table of the final Gstar across all simulations\n",
        capture.output(GstarSum)[1], "\n",
        capture.output(GstarSum)[2], "\n"
      )

      ratioGstarSum <- object@ratioGstarSummary

      r$dfSave(as.numeric(ratioGstarSum[1]), "ratioGstarMin")
      r$dfSave(as.numeric(ratioGstarSum[2]), "ratioGstarlower")
      r$dfSave(as.numeric(ratioGstarSum[3]), "ratioGstarMedian")
      r$dfSave(as.numeric(ratioGstarSum[4]), "ratioGstarMean")
      r$dfSave(as.numeric(ratioGstarSum[5]), "ratioGstarUpper")
      r$dfSave(as.numeric(ratioGstarSum[6]), "ratioGstarMax")

      cat(
        "The summary table of the final ratios of the Gstar across all simulations\n",
        capture.output(ratioGstarSum)[1], "\n",
        capture.output(ratioGstarSum)[2], "\n"
      )

      FinalDoseRecSum <- object@FinalDoseRecSummary

      r$dfSave(as.numeric(FinalDoseRecSum[1]), "FinalDoseRecMin")
      r$dfSave(as.numeric(FinalDoseRecSum[2]), "FinalDoseReclower")
      r$dfSave(as.numeric(FinalDoseRecSum[3]), "FinalDoseRecMedian")
      r$dfSave(as.numeric(FinalDoseRecSum[4]), "FinalDoseRecMean")
      r$dfSave(as.numeric(FinalDoseRecSum[5]), "FinalDoseRecUpper")
      r$dfSave(as.numeric(FinalDoseRecSum[6]), "FinalDoseRecMax")

      cat(
        "The summary table of dose levels, the optimal dose\n to recommend for subsequent study across all simulations\n",
        capture.output(FinalDoseRecSum)[1], "\n",
        capture.output(FinalDoseRecSum)[2], "\n"
      )

      FinalratioSum <- object@FinalRatioSummary

      r$dfSave(as.numeric(FinalratioSum[1]), "FinalratioMin")
      r$dfSave(as.numeric(FinalratioSum[2]), "Finalratiolower")
      r$dfSave(as.numeric(FinalratioSum[3]), "FinalratioMedian")
      r$dfSave(as.numeric(FinalratioSum[4]), "FinalratioMean")
      r$dfSave(as.numeric(FinalratioSum[5]), "FinalratioUpper")
      r$dfSave(as.numeric(FinalratioSum[6]), "FinalratioMax")

      cat(
        "The summary table of the final ratios of the optimal dose for stopping across
        all simulations\n",
        capture.output(FinalratioSum)[1], "\n",
        capture.output(FinalratioSum)[2], "\n"
      )


      r$report("EffFitAtDoseMostSelected",
        "Fitted expected efficacy level at dose most often selected",
        percent = FALSE,
        digits = 1
      )

      # Report individual stopping rules with non-<NA> labels.

      stop_pct_to_print <- h_calc_report_label_percentage(object@stop_report)

      if (length(stop_pct_to_print) > 0) {
        cat(
          "Stop reason triggered:\n",
          paste(names(stop_pct_to_print), ": ", stop_pct_to_print, "%\n")
        )
      }


      ## and return the updated information
      names(r$df) <- r$dfNames
      invisible(r$df)
    }
)

## --------------------------------------------------------------------------------------------------
##' Plot the summary of Pseudo Dual Simulations summary
##'
##' This plot method can be applied to \code{\linkS4class{PseudoDualSimulationsSummary}} objects in order
##' to summarize them graphically. Possible \code{type} of plots at the moment are those listed in
##' \code{\link{plot,PseudoSimulationsSummary,missing-method}} plus:
##' \describe{\item{meanEffFit}{Plot showing the fitted dose-efficacy curve. If no samples are involved, only the
##' average fitted dose-efficacy curve across the trials will be plotted. If samples (DLE and efficacy) are involved,
##' the average fitted dose-efficacy curve across the trials, together with the 95% credibility interval; and comparison
##' with the assumed truth (as specified by the \code{trueEff} argument to
##' \code{\link{summary,PseudoDualSimulations-method}})}}
##' You can specify any subset of these in the \code{type} argument.
##'
##' @param x the \code{\linkS4class{PseudoDualSimulationsSummary}} object we want to plot from
##' @param y missing
##' @param type the types of plots you want to obtain.
##' @param \dots not used
##' @return A single \code{\link[ggplot2]{ggplot}} object if a single plot is
##' asked for, otherwise a \code{\link{gridExtra}{gTree}} object.
##'
##' @importFrom ggplot2 geom_histogram ggplot aes xlab ylab geom_line
##' scale_linetype_manual scale_colour_manual
##' @importFrom gridExtra arrangeGrob
##'
##' @example examples/Simulations-method-plotSUMDual.R
##' @export
##' @keywords methods
setMethod("plot",
  signature =
    signature(
      x = "PseudoDualSimulationsSummary",
      y = "missing"
    ),
  def =
    function(x,
             y,
             type =
               c(
                 "nObs",
                 "doseSelected",
                 "propDLE",
                 "nAboveTargetEndOfTrial",
                 "meanFit",
                 "meanEffFit"
               ),
             ...) {
      ## which plots should be produced?
      type <- match.arg(type,
        several.ok = TRUE
      )
      stopifnot(length(type) > 0L)

      ## substract the specific plot types for dual-endpoint
      ## designs
      typeReduced <- setdiff(
        type,
        "meanEffFit"
      )

      ## are there more plots from general?
      moreFromGeneral <- (length(typeReduced) > 0)

      ## if so, then produce these plots
      if (moreFromGeneral) {
        ret <- callNextMethod(x = x, y = y, type = typeReduced)
      }

      ## is the meanBiomarkerFit plot requested?
      if ("meanEffFit" %in% type) { ## Find if Effsamples are generated in the simulations
        ## by checking if there the lower limits of the 95% Credibility
        ## interval are calculated
        if (!is.null(x@meanEffFit$lower)) {
          ## which types of lines do we have?
          linetype <- c(
            "True Expected Efficacy",
            "Average estimated expected efficacy",
            "95% interval for estimated expected efficacy"
          )

          ## create the data frame, with
          ## true biomarker, average estimated expected efficacy, and 95% (lower, upper)
          ## estimated biomarker stacked below each other
          dat <- data.frame(
            dose =
              rep(x@doseGrid, 4L),
            group =
              rep(1:4, each = length(x@doseGrid)),
            linetype =
              factor(
                rep(linetype[c(1, 2, 3, 3)],
                  each = length(x@doseGrid)
                ),
                levels = linetype
              ),
            lines =
              unlist(x@meanEffFit)
          )

          ## linetypes for the plot
          lt <- c(
            "True Expected Efficacy" = 1,
            "Average estimated expected efficacy" = 1,
            "95% interval for estimated expected efficacy" = 2
          )

          ## colour for the plot
          col <- c(
            "True Expected Efficacy" = 1,
            "Average estimated expected efficacy" = 4,
            "95% interval for estimated expected efficacy" = 4
          )

          ## now create and save the plot
          thisPlot <- ggplot() +
            geom_line(
              aes(
                x = dose,
                y = lines,
                group = group,
                linetype = linetype,
                col = linetype
              ),
              data = dat
            )

          thisPlot <- thisPlot +
            scale_linetype_manual(values = lt) +
            scale_colour_manual(values = col) +
            xlab("Dose level") +
            ylab("Expected Efficacy level")
        } else {
          linetype <- c(
            "True Expected Efficacy",
            "Average estimated expected efficacy"
          )

          ## create the data frame, with
          ## true biomarker, average estimated expected efficacy
          dat <- data.frame(
            dose =
              rep(x@doseGrid, 2L),
            group =
              rep(1:2, each = length(x@doseGrid)),
            linetype =
              factor(
                rep(linetype[c(1, 2)],
                  each = length(x@doseGrid)
                ),
                levels = linetype
              ),
            lines =
              unlist(x@meanEffFit)
          )

          ## linetypes for the plot
          lt <- c(
            "True Expected Efficacy" = 1,
            "Average estimated expected efficacy" = 1
          )

          ## colour for the plot
          col <- c(
            "True Expected Efficacy" = 1,
            "Average estimated expected efficacy" = 4
          )

          ## now create and save the plot
          thisPlot <- ggplot() +
            geom_line(
              aes(
                x = dose,
                y = lines,
                group = group,
                linetype = linetype,
                col = linetype
              ),
              data = dat
            )

          thisPlot <- thisPlot +
            scale_linetype_manual(values = lt) +
            scale_colour_manual(values = col) +
            xlab("Dose level") +
            ylab("Expected Efficacy level")
        }

        ## add this plot to the bottom
        ret <-
          if (moreFromGeneral) {
            gridExtra::arrangeGrob(ret, thisPlot, heights = c(2 / 3, 1 / 3))
          } else {
            thisPlot
          }
      }

      ## then finally plot everything
      ret
    }
)

# nolint end

#' Helpers for stripping expressions of `covr`-inserted trace code
#'
#' Workarounds to allow the package to continue to work while running `covr`
#' with minimal changes to the package code.
#'
#' @details
#' When using `covr`, the source code for package objects are modified to add
#' callbacks for each expression to log its execution. Given an arbitrary
#' expression, such as:
#'
#'     expr
#'
#' The code will be modified before executing any package code to look like:
#'
#'     if (TRUE) {
#'       covr:::count("file.R:1:2:3:4:5:6:7:8")
#'       expr
#'     }
#'
#' These functions are used for stripping expressions of this code so that the
#' package continues to work as intended while running tests as part of running
#' `covr` to calculate package coverage.
#'
#' This method is non-exhaustive, covering only a subset of `covr`'s tracing
#' behaviors necessary for this package.
#'
#' @param expr (`language`)\cr an R expression or call to test or strip of
#'   `covr` trace counters.
#'
#' @return A logical value or transformed expression with calls to
#'   `covr:::count` removed.
#'
#' @name h_covr_helpers
#' @keywords internal
#'
NULL

#' @describeIn h_covr_helpers
#' Determine whether `covr` is currently running
h_covr_active <- function() {
  identical(Sys.getenv("R_COVR"), "true")
}

#' @describeIn h_covr_helpers
#' Remove `covr` traces from an expression
h_covr_detrace <- function(expr) {
  if (!h_covr_active()) {
    return(expr)
  }

  if (is.function(expr)) {
    body(expr) <- h_covr_detrace(body(expr))
    return(expr)
  }

  detrace <- function(x) {
    # returns "missing" expression to avoid errors with calls
    if (identical(x, bquote())) {
      return(x)
    }

    x <- h_covr_detrace_call(x)
    if (is.call(x)) x[-1] <- lapply(x[-1], h_covr_detrace)
    x
  }

  detrace(expr)
}

#' @describeIn h_covr_helpers
#' Determine whether the current expression is a `covr`-modified expression
h_is_covr_trace <- function(expr) {
  # Matches `if (TRUE) { covr:::count(<trace>); <expr> }` (see covr:::trace_calls).
  is.call(expr) &&
    expr[[1]] == "if" &&
    expr[[2]] == quote(TRUE) &&
    expr[[3]][[1]] == "{" &&
    length(expr[[3]] >= 3) &&
    is.call(expr[[3]][[2]]) &&
    expr[[3]][[2]][[1]] == call(":::", as.symbol("covr"), as.symbol("count"))
}

#' @describeIn h_covr_helpers
#' Extract the original expression from a `covr`-modified expression
h_covr_detrace_call <- function(expr) {
  if (h_is_covr_trace(expr)) expr[[3]][[3]] else expr
}

#' @include helpers.R
#' @include Data-validity.R
#' @include CrmPackClass-class.R
NULL

# GeneralData-class ----

#' `GeneralData`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`GeneralData`] is a class for general data input.
#'
#' @slot ID (`integer`)\cr unique patient IDs.
#' @slot cohort (`integer`)\cr the cohort (non-negative sorted) indices.
#' @slot nObs (`integer`)\cr number of observations, a single value.
#'
#' @aliases GeneralData
#' @export
#'
.GeneralData <- setClass(
  Class = "GeneralData",
  slots = c(
    ID = "integer",
    cohort = "integer",
    nObs = "integer"
  ),
  prototype = prototype(
    ID = integer(),
    cohort = integer(),
    nObs = 0L
  ),
  contains = "CrmPackClass",
  validity = v_general_data
)

## default constructor ----

#' @rdname GeneralData-class
#' @note Typically, end users will not use the `.DefaultDataGeneral()` function.
#' @export
.DefaultDataGeneral <- function() {
  stop(paste0("Class DataGeneral cannot be instantiated directly.  Please use one of its subclasses instead."))
}

# Data ----

## class ----

#' `Data`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`Data`] is a class for the data input.
#' It inherits from [`GeneralData`].
#'
#' @slot x (`numeric`)\cr the doses for the patients.
#' @slot y (`integer`)\cr the vector of toxicity events (0 or 1 integers).
#' @slot doseGrid (`numeric`)\cr the vector of all possible doses (sorted),
#'   i.e. the dose grid.
#' @slot nGrid (`integer`)\cr number of gridpoints.
#' @slot xLevel (`integer`)\cr the levels for the doses the patients have been given,
#'   w.r.t `doseGrid`.
#' @slot placebo (`logical`)\cr if `TRUE` the first dose level
#'   in the `doseGrid`is considered as PLACEBO.
#'
#' @aliases Data
#' @export
#'
.Data <- setClass(
  Class = "Data",
  contains = "GeneralData",
  slots = c(
    x = "numeric",
    y = "integer",
    doseGrid = "numeric",
    nGrid = "integer",
    xLevel = "integer",
    placebo = "logical"
  ),
  prototype = prototype(
    x = numeric(),
    y = integer(),
    doseGrid = numeric(),
    nGrid = 0L,
    xLevel = integer(),
    placebo = FALSE
  ),
  validity = v_data
)

## constructor ----

#' @rdname Data-class
#'
#' @details The `cohort` can be missing if and only if `placebo` is equal to
#'   `FALSE`.
#'
#' @note `ID` and `cohort` can be missing. Then a message will be issued
#'   and the variables will be filled with default IDs and best guesses cohort,
#'   i.e. a sorted (in ascending order) sequence of values from `{1, 2, ...}`.
#'
#' @param x (`numeric`)\cr the doses for the patients.
#' @param y (`integer`)\cr the vector of toxicity events (0 or 1).
#'   You can also supply `numeric` vectors, but these will then be converted to
#'   `integer` internally.
#' @param ID (`integer`)\cr unique patient IDs.
#'   You can also supply `numeric` vectors, but these will then be converted to
#'   `integer` internally.
#' @param cohort (`integer`)\cr the cohort (non-negative sorted) indices.
#'   You can also supply `numeric` vectors, but these will then be converted to
#'   `integer` internally.
#' @param doseGrid (`numeric`)\cr all possible doses.
#' @param placebo (`flag`)\cr if `TRUE` the first dose level
#'   in the `doseGrid` is considered as placebo.
#' @param ... not used.
#'
#' @export
#' @example examples/Data-class.R
#'
Data <- function(x = numeric(),
                 y = integer(),
                 ID = integer(),
                 cohort = integer(),
                 doseGrid = numeric(),
                 placebo = FALSE,
                 ...) {
  assert_numeric(x)
  assert_integerish(y, lower = 0, upper = 1, any.missing = FALSE)
  assert_integerish(ID, unique = TRUE, any.missing = FALSE)
  assert_integerish(cohort)
  assert_numeric(doseGrid, any.missing = FALSE, unique = TRUE)
  assert_flag(placebo)

  doseGrid <- sort(doseGrid)
  assert_subset(x, doseGrid)

  if (length(ID) == 0 && length(x) > 0) {
    message("Used default patient IDs!")
    ID <- seq_along(x)
  } else {
    assert_integerish(ID, unique = TRUE)
  }

  if (!placebo && length(cohort) == 0 && length(x) > 0) {
    message("Used best guess cohort indices!")
    # This is just assuming that consecutive patients
    # in the data set are in the same cohort if they
    # have the same dose. Note that this could be wrong,
    # if two subsequent cohorts are at the same dose.
    cohort <- as.integer(c(1, 1 + cumsum(diff(x) != 0)))
  } else {
    assert_integerish(cohort)
  }

  .Data(
    x = as.numeric(x),
    y = as.integer(y),
    ID = as.integer(ID),
    cohort = as.integer(cohort),
    doseGrid = as.numeric(doseGrid),
    nObs = length(x),
    nGrid = length(doseGrid),
    xLevel = match_within_tolerance(x, doseGrid),
    placebo = placebo
  )
}

## default constructor ----

#' @rdname Data-class
#' @note Typically, end users will not use the `.DefaultData()` function.
#' @export
.DefaultData <- function() {
  Data(
    doseGrid = c(1, 3, 5, 10, 15, 20, 25, 40, 50, 80, 100),
    ID = 1L:3L,
    cohort = 1L:3L,
    x = c(1, 3, 5),
    y = rep(0L, 3)
  )
}

# DataDual ----

## class ----

#' `DataDual`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`DataDual`] is a class for the dual endpoint data.
#' It inherits from [`Data`] and it contains additional biomarker information.
#'
#' @slot w (`numeric`)\cr the continuous vector of biomarker values.
#'
#' @aliases DataDual
#' @export
#'
.DataDual <- setClass(
  Class = "DataDual",
  slots = c(w = "numeric"),
  prototype = prototype(w = numeric()),
  contains = "Data",
  validity = v_data_dual
)

## constructor ----

#' @rdname DataDual-class
#'
#' @param w (`numeric`)\cr the continuous vector of biomarker values.
#' @param ... parameters passed to [Data()].
#'
#' @export
#' @example examples/Data-class-DataDual.R
#'
DataDual <- function(w = numeric(),
                     ...) {
  d <- Data(...)
  .DataDual(d, w = w)
}


## default constructor ----

#' @rdname DataDual-class
#' @note Typically, end users will not use the `.DefaultDataDual()` function.
#' @export
.DefaultDataDual <- function() {
  DataDual(
    x = c(0.1, 0.5, 1.5, 3, 6, 10, 10, 10),
    y = c(0, 0, 0, 0, 0, 0, 1, 0),
    w = rnorm(8),
    doseGrid = c(0.1, 0.5, 1.5, 3, 6, seq(from = 10, to = 80, by = 2)),
    ID = 1L:8L,
    cohort = as.integer(c(1, 2, 3, 4, 5, 6, 6, 6))
  )
}

# DataParts ----

## class ----

#' `DataParts`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`DataParts`] is a class for the data with two study parts.
#' It inherits from [`Data`] and it contains additional information
#' on the two study parts.
#'
#' @slot part (`integer`)\cr which part does each of the patients belong to?
#' @slot nextPart (`count`)\cr what is the part for the next cohort (1 or 2)?
#' @slot part1Ladder (`numeric`)\cr what is the escalation ladder for
#'   part 1? This shall be an ordered subset of the `doseGrid`.
#'
#' @aliases DataParts
#' @export
#'
.DataParts <- setClass(
  Class = "DataParts",
  slots = c(
    part = "integer",
    nextPart = "integer",
    part1Ladder = "numeric"
  ),
  prototype = prototype(
    part = integer(),
    nextPart = 1L,
    part1Ladder = numeric()
  ),
  contains = "Data",
  validity = v_data_parts
)

## constructor ----

#' @rdname DataParts-class
#'
#' @param part (`integer`)\cr which part does each of the patients belong to?
#' @param nextPart (`count`)\cr what is the part for the next cohort (1 or 2)?
#' @param part1Ladder (`numeric`)\cr what is the escalation ladder for part 1?
#'   This shall be an ordered subset of the `doseGrid`.
#' @param ... parameters passed to [Data()].
#'
#' @export
#' @example examples/Data-class-DataParts.R
#'
DataParts <- function(part = integer(),
                      nextPart = 1L,
                      part1Ladder = numeric(),
                      ...) {
  d <- Data(...)
  .DataParts(
    d,
    part = part,
    nextPart = nextPart,
    part1Ladder = part1Ladder
  )
}

## default constructor ----

#' @rdname DataParts-class
#' @note Typically, end users will not use the `.DefaultDataParts()` function.
#' @export
.DefaultDataParts <- function() {
  DataParts(
    x = c(0.1, 0.5, 1.5),
    y = c(0, 0, 0),
    ID = 1:3,
    cohort = 1:3,
    doseGrid = c(0.1, 0.5, 1.5, 3, 6, seq(from = 10, to = 80, by = 2)),
    part = c(1L, 1L, 1L),
    nextPart = 1L,
    part1Ladder = c(0.1, 0.5, 1.5, 3, 6, 10)
  )
}


# DataMixture ----

## class ----

#' `DataMixture`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`DataMixture`] is a class for the data with mixture sharing.
#' It inherits from [`Data`] and it contains additional information
#' on the mixture sharing.
#'
#' @slot xshare (`numeric`)\cr the doses for the share patients.
#' @slot yshare (`integer`)\cr the vector of toxicity events (0 or 1)
#'   for the share patients.
#' @slot nObsshare (`count`)\cr number of share patients.
#'
#' @aliases DataMixture
#' @export
#'
.DataMixture <- setClass(
  Class = "DataMixture",
  slots = c(
    xshare = "numeric",
    yshare = "integer",
    nObsshare = "integer"
  ),
  prototype = prototype(
    xshare = numeric(),
    yshare = integer(),
    nObsshare = 0L
  ),
  contains = "Data",
  validity = v_data_mixture
)

## constructor ----

#' @rdname DataMixture-class
#'
#' @param xshare (`numeric`)\cr the doses for the share patients.
#' @param yshare (`integer`)\cr the vector of toxicity events (0 or 1)
#'   for the share patients. You can also supply `numeric` vectors,
#'   but these will then be converted to `integer` internally.
#' @param ... parameters passed to [Data()].
#'
#' @export
#' @example examples/Data-class-DataMixture.R
#'
DataMixture <- function(xshare = numeric(),
                        yshare = integer(),
                        ...) {
  d <- Data(...)
  assert_integerish(yshare)
  assert_numeric(xshare)
  .DataMixture(
    d,
    xshare = as.numeric(xshare),
    yshare = as.integer(yshare),
    nObsshare = length(xshare)
  )
}

## default constructor ----

#' @rdname DataMixture-class
#' @note Typically, end users will not use the `.DefaultDataMixture()` function.
#' @export
.DefaultDataMixture <- function() {
  DataMixture(
    xshare = c(12, 14, 16, 18.0),
    yshare = c(0L, 1L, 1L, 1L),
    nObsshare = 4L,
    x = c(0.1, 0.5, 1.5),
    y = c(0, 0, 0),
    ID = 1L:3L,
    cohort = 1L:3L,
    doseGrid = c(0.1, 0.5, 1.5, 3, 6, seq(from = 10, to = 80, by = 2))
  )
}


# DataDA ----

## class ----

#' `DataDA`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`DataDA`] is a class for the time-to-DLT augmented data.
#' It inherits from [`Data`] and it contains additional DLT free survival times.
#'
#' @note `survival time` here refers to the time period for which the subject
#'   did not experience any DLT, and is not referring to deaths.
#'
#' @slot u (`numeric`)\cr the continuous vector of DLT free survival times.
#' @slot t0 (`numeric`)\cr time of initial dosing for each patient.
#'   Non-negative values sorted in ascending order.
#' @slot Tmax (`number`)\cr the DLT observation period.
#'
#' @aliases DataDA
#' @export
#'
.DataDA <- setClass(
  Class = "DataDA",
  slots = c(
    u = "numeric",
    t0 = "numeric",
    Tmax = "numeric"
  ),
  prototype = prototype(
    u = numeric(),
    t0 = numeric(),
    Tmax = 0 + .Machine$double.xmin
  ),
  contains = "Data",
  validity = v_data_da
)

## constructor ----

#' @rdname DataDA-class
#'
#' @param u (`numeric`)\cr the continuous vector of DLT free survival times.
#' @param t0 (`numeric`)\cr time of initial dosing for each patient.
#'   Non-negative values sorted in ascending order.
#'   Default to vector of 0s of length equal to length of `u`.
#' @param Tmax (`number`)\cr the DLT observation period.
#' @param ... parameters passed to [Data()].
#'
#' @export
#' @example examples/Data-class-DataDA.R
#'
DataDA <- function(u = numeric(),
                   t0 = numeric(length(u)),
                   Tmax = 0 + .Machine$double.xmin,
                   ...) {
  d <- Data(...)
  .DataDA(
    d,
    u = as.numeric(u),
    t0 = as.numeric(t0),
    Tmax = as.numeric(Tmax)
  )
}

## default constructor ----

#' @rdname DataDA-class
#' @note Typically, end users will not use the `.DefaultDataDA()` function.
#' @export
.DefaultDataDA <- function() {
  DataDA(
    u = c(42, 30, 15, 5, 20, 25, 30, 60),
    t0 = c(0, 15, 30, 40, 55, 70, 75, 85),
    Tmax = 60,
    x = c(0.1, 0.5, 1.5, 3, 6, 10, 10, 10),
    y = c(0, 0, 1, 1, 0, 0, 1, 0),
    doseGrid = c(0.1, 0.5, 1.5, 3, 6, seq(from = 10, to = 80, by = 2)),
    ID = 1L:8L,
    cohort = as.integer(c(1, 2, 3, 4, 5, 6, 6, 6))
  )
}

# DataOrdinal ----

## class ----

#' `DataOrdinal`
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' [`DataOrdinal`] is a class for ordinal toxicity data.
#' It inherits from [`GeneralData`] and it describes toxicity responses on an
#' ordinal rather than binary scale.
#'
#' @note This class has been implemented as a sibling of the existing `Data` class
#' (rather than as a parent or child) to minimise the risk of unintended side
#' effects on existing classes and methods.
#'
#' The default setting for the `yCategories` slot replicates the behaviour
#' of the existing `Data` class.
#'
#' @aliases DataOrdinal
#' @export
.DataOrdinal <- setClass(
  Class = "DataOrdinal",
  contains = "GeneralData",
  slots = c(
    x = "numeric",
    y = "integer",
    doseGrid = "numeric",
    nGrid = "integer",
    xLevel = "integer",
    yCategories = "integer",
    placebo = "logical"
  ),
  prototype = prototype(
    x = numeric(),
    y = integer(),
    doseGrid = numeric(),
    nGrid = 0L,
    xLevel = integer(),
    yCategories = c("No DLT" = 0L, "DLT" = 1L),
    placebo = FALSE
  ),
  validity = v_data_ordinal
)

## constructor ----

#' @rdname DataOrdinal-class
#' @param yCategories (named `integer`)\cr the names and codes for the
#' toxicity categories used in the data.  Category labels are taken from the
#' names of the vector.  The names of the vector must be unique and its values
#' must be sorted and take the values 0, 1, 2, ...
#' @inheritParams Data
#' @inherit Data details note params
#' @example examples/Data-class-DataOrdinal.R
#' @export
DataOrdinal <- function(x = numeric(),
                        y = integer(),
                        ID = integer(),
                        cohort = integer(),
                        doseGrid = numeric(),
                        placebo = FALSE,
                        yCategories = c("No DLT" = 0L, "DLT" = 1L),
                        ...) {
  assert_numeric(doseGrid, any.missing = FALSE, unique = TRUE)
  assert_integerish(
    yCategories,
    any.missing = FALSE,
    unique = TRUE,
    names = "unique",
    min.len = 2
  )
  assert_flag(placebo)

  doseGrid <- as.numeric(sort(doseGrid))

  if (length(ID) == 0 && length(x) > 0) {
    message("Used default patient IDs!")
    ID <- seq_along(x)
  } else {
    assert_integerish(ID, unique = TRUE)
  }

  if (!placebo && length(cohort) == 0 && length(x) > 0) {
    message("Used best guess cohort indices!")
    # This is just assuming that consecutive patients
    # in the data set are in the same cohort if they
    # have the same dose. Note that this could be wrong,
    # if two subsequent cohorts are at the same dose.
    cohort <- as.integer(c(1, 1 + cumsum(diff(x) != 0)))
  } else {
    assert_integerish(cohort)
  }

  .DataOrdinal(
    x = as.numeric(x),
    y = as.integer(y),
    ID = as.integer(ID),
    cohort = as.integer(cohort),
    doseGrid = doseGrid,
    nObs = length(x),
    nGrid = length(doseGrid),
    xLevel = match_within_tolerance(x = x, table = doseGrid),
    placebo = placebo,
    yCategories = yCategories
  )
}


## default constructor ----

#' @rdname DataOrdinal-class
#' @note Typically, end users will not use the `.DefaultDataOrdinal()` function.
#' @export
.DefaultDataOrdinal <- function() {
  DataOrdinal(
    x = c(10, 20, 30, 40, 50, 50, 50, 60, 60, 60),
    y = as.integer(c(0, 0, 0, 0, 0, 1, 0, 0, 1, 2)),
    ID = 1L:10L,
    cohort = as.integer(c(1:4, 5, 5, 5, 6, 6, 6)),
    doseGrid = c(seq(from = 10, to = 100, by = 10)),
    yCategories = c("No tox" = 0L, "Sub-tox AE" = 1L, "DLT" = 2L),
    placebo = FALSE
  )
}

# DataGrouped ----

## class ----

#' `DataGrouped`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`DataGrouped`] is a class for a two groups dose escalation data set,
#' comprised of a monotherapy (`mono`) and a combination therapy (`combo`)
#' arm. It inherits from [`Data`] and it contains the additional group information.
#'
#' @slot group (`factor`)\cr whether `mono` or `combo` was used.
#'
#' @aliases DataGrouped
#' @export
.DataGrouped <- setClass(
  Class = "DataGrouped",
  slots = c(
    group = "factor"
  ),
  prototype = prototype(
    group = factor(levels = c("mono", "combo"))
  ),
  contains = "Data",
  validity = v_data_grouped
)

#' @rdname DataGrouped-class
#'
#' @param group (`factor` or `character`)\cr whether `mono` or `combo` was used.
#'   If `character` then will be coerced to `factor` with the correct levels
#'   internally.
#' @param ... parameters passed to [Data()].
#'
#' @export
#' @example examples/Data-class-DataGrouped.R
#'
DataGrouped <- function(group = character(),
                        ...) {
  d <- Data(...)
  if (!is.factor(group)) {
    assert_character(group)
    assert_subset(group, choices = c("mono", "combo"))
    group <- factor(group, levels = c("mono", "combo"))
  }
  .DataGrouped(
    d,
    group = group
  )
}

## default constructor ----

#' @rdname DataGrouped-class
#' @note Typically, end users will not use the `.DefaultDataGrouped()` function.
#' @export
.DefaultDataGrouped <- function() {
  DataGrouped()
}

# GeneralSimulations ----

#' Internal Helper Functions for Validation of [`GeneralSimulations`] Objects
#'
#' @description `r lifecycle::badge("stable")`
#'
#' These functions are only used internally to validate the format of an input
#' [`GeneralSimulations`] or inherited classes and therefore not exported.
#'
#' @name v_general_simulations
#' @param object (`GeneralSimulations`)\cr object to validate.
#' @return A `character` vector with the validation failure messages,
#'   or `TRUE` in case validation passes.
NULL

#' @describeIn v_general_simulations validates that the [`GeneralSimulations`] object
#'   contains valid `data` object and valid `dose` simulations.

v_general_simulations <- function(object) {
  v <- Validate()

  nSims <- length(object@data)

  v$check(
    all(sapply(object@data, is, "Data")),
    "all data elements must be Data objects"
  )
  v$check(
    identical(length(object@doses), nSims),
    "doses must have same length as the data list"
  )

  v$result()
}

#' @describeIn v_general_simulations validates that the [`Simulations`] object
#'   contains valid object `fit`, `stop_reasons`, `stop_report`, and
#'   `additional_stats` compared to the general class [`GeneralSimulations`].
#'
v_simulations <- function(object) {
  v <- Validate()

  nSims <- length(object@data)

  v$check(
    identical(length(object@fit), nSims),
    "fit must have same length as data"
  )
  v$check(
    identical(length(object@stop_reasons), nSims),
    "stop_reasons must have same length as data"
  )

  v$check(
    checkmate::test_matrix(object@stop_report,
      mode = "logical",
      nrows = nSims,
      min.cols = 1,
      any.missing = FALSE
    ),
    "stop_report must be a matrix of mode logical in which the number of rows
    equals the number of simulations and which must not contain any missing values"
  )

  v$result()
}

#' @describeIn v_general_simulations validates that the [`DualSimulations`] object and
#' capture the dose-biomarker `fits`, and the `sigma2W` and `rho` estimates.
#'
v_dual_simulations <- function(object) {
  v <- Validate()

  nSims <- length(object@data)

  v$check(
    identical(length(object@fit_biomarker), nSims),
    "fit_biomarker list has to have same length as data"
  )
  v$check(
    identical(length(object@rho_est), nSims),
    "rho_est vector has to have same length as data"
  )
  v$check(
    identical(length(object@sigma2w_est), nSims),
    "sigma2w_est has to have same length as data"
  )

  v$result()
}

# PseudoSimulations ----

#' Internal Helper Functions for Validation of [`PseudoSimulations`] Objects
#'
#' @description `r lifecycle::badge("stable")`
#'
#' These functions are only used internally to validate the format of an input
#' [`PseudoSimulations`] or inherited classes and therefore not exported.
#'
#' @name v_pseudo_simulations
#' @param object (`PseudoSimulations`)\cr object to validate.
#' @return A `character` vector with the validation failure messages,
#'   or `TRUE` in case validation passes.
NULL

#' @describeIn v_pseudo_simulations validates that the [`PseudoSimulations`] object
#'   contains valid `fit`, `FinalTDtargetEndOfTrialEstimates` ,
#'   `FinalTDtargetDuringTrialAtDoseGrid`,`FinalTDtargetEndOfTrialAtDoseGrid` ,
#'   `FinalTDEOTCIs`, `FinalTDEOTRatios`, `FinalCIs`, `FinalRatios`,
#'     object and valid `stopReasons` simulations.

v_pseudo_simulations <- function(object) {
  v <- Validate()

  nSims <- length(object@data)
  v$check(
    identical(length(object@stopReasons), nSims),
    "stopReasons must have same length as data"
  )

  v$result()
}

#' @describeIn v_pseudo_simulations validates that the [`PseudoDualSimulations`] object
#'   contains valid `fitEff`, `FinalGstarEstimates` , `FinalGstarAtDoseGrid`,
#'    `FinalGstarCIs` , `FinalGstarRatios`, `FinalOptimalDose`, `FinalOptimalDoseAtDoseGrid`
#'     object and valid `sigma2est` simulations.

v_pseudo_dual_simulations <- function(object) {
  v <- Validate()
  nSims <- length(object@data)
  v$check(
    identical(length(object@sigma2est), nSims),
    "sigma2est has to have same length as data"
  )
  v$result()
}

#' @describeIn v_pseudo_simulations validates that the [`PseudoDualFlexiSimulations`]
#' object contains valid `sigma2betaWest` vector of the final posterior mean
#' sigma2betaW estimates.`FinalGstarEstimates` , `FinalGstarAtDoseGrid`,
#'
v_pseudo_dual_flex_simulations <- function(object) {
  v <- Validate()
  nSims <- length(object@data)
  v$check(
    identical(length(object@sigma2betaWest), nSims),
    "sigma2betaWest has to have same length as data"
  )
  v$result()
}

#' @describeIn v_general_simulations validates that the [`DASimulations`] object
#'   contains valid `trialduration` the vector of trial duration values for all
#'   simulations.

v_da_simulations <- function(object) {
  v <- Validate()

  nSims <- length(object@data)

  v$check(
    identical(length(object@trialduration), nSims),
    "trialduration vector has to have same length as data"
  )

  v$result()
}

#' @include helpers.R
#' @include Rules-validity.R
#' @include CrmPackClass-class.R
NULL

# NextBest ----

## class ----

#' `NextBest`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`NextBest`] is a virtual class for finding next best dose, from which all
#' other specific next best dose classes inherit.
#'
#' @seealso [`NextBestMTD`], [`NextBestNCRM`], [`NextBestDualEndpoint`],
#'   [`NextBestThreePlusThree`], [`NextBestDualEndpoint`], [`NextBestMinDist`],
#'   [`NextBestInfTheory`], [`NextBestTD`], [`NextBestTDsamples`],
#'   [`NextBestMaxGain`], [`NextBestMaxGainSamples`].
#'
#' @aliases NextBest
#' @export
#'
setClass(
  Class = "NextBest",
  contains = "CrmPackClass"
)

## default constructor ----

#' @rdname NextBest-class
#' @note Typically, end users will not use the `DefaultNextBest()` function.
#' @export
.DefaultNextBest <- function() {
  stop(paste0("Class NextBest should not be instantiated directly.  Please use one of its subclasses instead."))
}


# NextBestMTD ----

## class ----

#' `NextBestMTD`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`NextBestMTD`] is the class for next best dose based on MTD estimate.
#'
#' @slot target (`proportion`)\cr target toxicity probability, except 0 or 1.
#' @slot derive (`function`)\cr a function which derives the final next best MTD
#'   estimate, based on vector of posterior MTD samples. It must therefore accept
#'   one and only one argument, which is a numeric vector, and return a number.
#'
#' @aliases NextBestMTD
#' @export
#'
.NextBestMTD <- setClass(
  Class = "NextBestMTD",
  slots = c(
    target = "numeric",
    derive = "function"
  ),
  prototype = prototype(
    target = 0.3,
    derive = function(mtd_samples) {
      quantile(mtd_samples, probs = 0.3)
    }
  ),
  contains = "NextBest",
  validity = v_next_best_mtd
)

## constructor ----

#' @rdname NextBestMTD-class
#'
#' @param target (`proportion`)\cr see slot definition.
#' @param derive (`function`)\cr see slot definition.
#'
#' @export
#' @example examples/Rules-class-NextBestMTD.R
#'
NextBestMTD <- function(target, derive) {
  .NextBestMTD(
    target = target,
    derive = derive
  )
}

## default constructor ----

#' @rdname NextBestMTD-class
#' @note Typically, end users will not use the `.DefaultNextBestMTD()` function.
#' @export
.DefaultNextBestMTD <- function() {
  NextBestMTD(
    target = 0.33,
    derive = function(mtd_samples) {
      quantile(mtd_samples, probs = 0.25)
    }
  )
}

# NextBestNCRM ----

## class ----

#' `NextBestNCRM`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`NextBestNCRM`] is the class for next best dose that finds the next dose
#' with high posterior probability to be in the target toxicity interval.
#'
#' @details To avoid numerical problems, the dose selection algorithm has been
#' implemented as follows: First admissible doses are found, which are those
#' with probability to fall in `overdose` category being below `max_overdose_prob`.
#' Next, within the admissible doses, the maximum probability to fall in the
#' `target` category is calculated. If that is above 5% (i.e. it is not just
#' numerical error), then the corresponding dose is the next recommended dose.
#' Otherwise, the highest admissible dose is the next recommended dose.
#'
#' @slot target (`numeric`)\cr the target toxicity interval (limits included).
#' @slot overdose (`numeric`)\cr the overdose toxicity interval (lower limit
#'   excluded, upper limit included). It is used to filter probability samples.
#' @slot max_overdose_prob (`proportion`)\cr maximum overdose posterior
#'   probability that is allowed, except 0 or 1.
#'
#' @aliases NextBestNCRM
#' @export
#'
.NextBestNCRM <- setClass(
  Class = "NextBestNCRM",
  slots = c(
    target = "numeric",
    overdose = "numeric",
    max_overdose_prob = "numeric"
  ),
  prototype = prototype(
    target = c(0.2, 0.35),
    overdose = c(0.35, 1),
    max_overdose_prob = 0.25
  ),
  contains = "NextBest",
  validity = v_next_best_ncrm
)

## constructor ----

#' @rdname NextBestNCRM-class
#'
#' @param target (`numeric`)\cr see slot definition.
#' @param overdose (`numeric`)\cr see slot definition.
#' @param max_overdose_prob (`proportion`)\cr see slot definition.
#' @export
#' @example examples/Rules-class-NextBestNCRM.R
#'
NextBestNCRM <- function(target,
                         overdose,
                         max_overdose_prob) {
  .NextBestNCRM(
    target = target,
    overdose = overdose,
    max_overdose_prob = max_overdose_prob
  )
}

## default constructor ----

#' @rdname NextBestNCRM-class
#' @note Typically, end users will not use the `.DefaultNextBestNCRM()` function.
#' @export
.DefaultNextBestNCRM <- function() {
  NextBestNCRM(target = c(0.2, 0.35), overdose = c(0.35, 1), max_overdose_prob = 0.25)
}

# NextBestNCRMLoss ----

## class ----

#' `NextBestNCRMLoss`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`NextBestNCRMLoss`] is the class based on NCRM rule and loss function.
#' This class is similar to [`NextBestNCRM`] class, but differences are the
#' addition of loss function and re-defined toxicity intervals, see each
#' toxicity interval documentation and the note for details. As in NCRM rule, first admissible doses are found,
#' which are those with probability to fall in overdose category being below
#' `max_overdose_prob`. Next, within the admissible doses, the loss function is
#' calculated, i.e. `losses` %*% `target`. Finally, the corresponding
#' dose with lowest loss function (Bayes risk) is recommended for the next dose.
#'
#' @slot target (`numeric`)\cr the target toxicity interval (limits included).
#'   It has to be a probability range excluding 0 and 1.
#' @slot overdose (`numeric`)\cr the overdose toxicity interval (lower limit
#'   excluded, upper limit included) or the excessive toxicity interval (lower
#'   limit excluded, upper limit included) if unacceptable is not provided.
#'   It has to be a probability range. It is used to filter probability samples.
#' @slot unacceptable (`numeric`)\cr an unacceptable toxicity
#'   interval (lower limit excluded, upper limit included). This must be
#'   specified if the `overdose` does not include 1. Otherwise, it is `c(1, 1)`
#'   (default), which is essentially a scalar equals 1. It has to be a
#'   probability range.
#' @slot losses (`numeric`)\cr a vector specifying the loss function. If the
#'   `unacceptable` is provided, the vector length must be 4, otherwise 3.
#'
#' @note The loss function should be a vector of either 3 or 4 values.
#'   This is because the loss function values must be specified for each
#'   interval, that is under-dosing, target toxicity, and overdosing toxicity or
#'   under-dosing, target toxicity, overdosing (excessive) toxicity, and
#'   unacceptable toxicity intervals.
#'
#' @aliases NextBestNCRMLoss
#' @export
#'
.NextBestNCRMLoss <- setClass(
  Class = "NextBestNCRMLoss",
  slots = c(
    unacceptable = "numeric",
    losses = "numeric"
  ),
  prototype = prototype(
    unacceptable = c(1, 1),
    losses = c(1, 0, 2)
  ),
  contains = "NextBestNCRM",
  validity = v_next_best_ncrm_loss
)

## constructor ----

#' @rdname NextBestNCRMLoss-class
#'
#' @param target (`numeric`)\cr see slot definition.
#' @param overdose (`numeric`)\cr see slot definition.
#' @param unacceptable (`numeric`)\cr see slot definition.
#' @param max_overdose_prob (`proportion`)\cr see slot definition in [`NextBestNCRM`].
#' @param losses (`numeric`)\cr see slot definition.
#'
#' @export
#' @example examples/Rules-class-NextBestNCRMLoss.R
#'
NextBestNCRMLoss <- function(target,
                             overdose,
                             unacceptable = c(1, 1),
                             max_overdose_prob,
                             losses) {
  .NextBestNCRMLoss(
    target = target,
    overdose = overdose,
    unacceptable = unacceptable,
    max_overdose_prob = max_overdose_prob,
    losses = losses
  )
}

## default constructor ----

#' @rdname NextBestNCRMLoss-class
#' @note Typically, end users will not use the `.DefaultNextBestnCRMLoss()` function.
#' @export
.DefaultNextBestNCRMLoss <- function() {
  NextBestNCRMLoss(
    target = c(0.2, 0.35),
    overdose = c(0.35, 0.6),
    unacceptable = c(0.6, 1),
    max_overdose_prob = 0.25,
    losses = c(1, 0, 1, 2)
  )
}


# NextBestThreePlusThree ----

## class ----

#' `NextBestThreePlusThree`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`NextBestThreePlusThree`] is the class for next best dose that
#' implements the classical 3+3 dose recommendation. No input is required,
#' hence this class has no slots.
#'
#' @aliases NextBestThreePlusThree
#' @export
#'
.NextBestThreePlusThree <- setClass(
  Class = "NextBestThreePlusThree",
  contains = "NextBest"
)

## constructor ----

#' @rdname NextBestThreePlusThree-class
#'
#' @export
#' @examples
#' # Next best dose class object using the classical 3+3 design.
#' my_next_best <- NextBestThreePlusThree()
NextBestThreePlusThree <- function() {
  .NextBestThreePlusThree()
}

## default constructor ----

#' @rdname NextBestThreePlusThree-class
#' @note Typically, end users will not use the `.DefaultNextBestThreePlusThree()` function.
#' @export
.DefaultNextBestThreePlusThree <- function() {
  NextBestThreePlusThree()
}

# NextBestDualEndpoint ----

## class ----

#' `NextBestDualEndpoint`
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' [`NextBestDualEndpoint`] is the class for next best dose that is based on the
#' dual endpoint model.
#'
#' @details Under this rule, at first admissible doses are found, which are those
#' with toxicity probability to fall in `overdose` category and being below
#' `max_overdose_prob`. Next, it picks (from the remaining admissible doses) the
#' one that maximizes the probability to be in the `target` biomarker range. By
#' default (`target_relative = TRUE`) the target is specified as relative to the
#' maximum biomarker level across the dose grid or relative to the `Emax`
#' parameter in case a parametric model was selected (i.e. [`DualEndpointBeta`],
#' [`DualEndpointEmax`]). However, if `target_relative = FALSE`, then the
#' absolute biomarker range can be used as a target.
#'
#' @slot target (`numeric`)\cr the biomarker target range that needs to be
#'   reached. For example, the target range \eqn{(0.8, 1.0)} and
#'   `target_relative = TRUE` means that we target a dose with at least
#'   \eqn{80\%} of maximum biomarker level. As an other example,
#'   \eqn{(0.5, 0.8)} would mean that we target a dose between \eqn{50\%} and
#'   \eqn{80\%} of the maximum biomarker level.
#' @slot overdose (`numeric`)\cr the overdose toxicity interval (lower limit
#'   excluded, upper limit included).
#' @slot max_overdose_prob (`proportion`)\cr maximum overdose probability that
#'   is allowed.
#' @slot target_relative (`flag`)\cr is `target` specified as relative? If
#'   `TRUE`, then the `target` is interpreted relative to the maximum, so it
#'   must be a probability range. Otherwise, the `target` is interpreted as
#'   absolute biomarker range.
#' @slot target_thresh (`proportion`)\cr a target probability threshold that
#'   needs to be fulfilled before the target probability will be used for
#'   deriving the next best dose (default to 0.01).
#'
#' @aliases NextBestDualEndpoint
#' @export
#'
.NextBestDualEndpoint <- setClass(
  Class = "NextBestDualEndpoint",
  slots = c(
    target = "numeric",
    overdose = "numeric",
    max_overdose_prob = "numeric",
    target_relative = "logical",
    target_thresh = "numeric"
  ),
  prototype = prototype(
    target = c(0.9, 1),
    overdose = c(0.35, 1),
    max_overdose_prob = 0.25,
    target_relative = TRUE,
    target_thresh = 0.01
  ),
  contains = "NextBest",
  validity = v_next_best_dual_endpoint
)

## constructor ----

#' @rdname NextBestDualEndpoint-class
#'
#' @param target (`numeric`)\cr see slot definition.
#' @param overdose (`numeric`)\cr see slot definition.
#' @param max_overdose_prob (`proportion`)\cr see slot definition.
#' @param target_relative (`flag`)\cr see slot definition.
#' @param target_thresh (`proportion`)\cr see slot definition.
#'
#' @export
#' @example examples/Rules-class-NextBestDualEndpoint.R
#'
NextBestDualEndpoint <- function(target,
                                 overdose,
                                 max_overdose_prob,
                                 target_relative = TRUE,
                                 target_thresh = 0.01) {
  .NextBestDualEndpoint(
    target = target,
    overdose = overdose,
    max_overdose_prob = max_overdose_prob,
    target_relative = target_relative,
    target_thresh = target_thresh
  )
}

## default constructor ----

#' @rdname NextBestDualEndpoint-class
#' @note Typically, end users will not use the `.DefaultNextBestDualEndpoint()` function.
#' @export
.DefaultNextBestDualEndpoint <- function() {
  NextBestDualEndpoint(
    target = c(200, 300),
    overdose = c(0.35, 1),
    max_overdose_prob = 0.25,
    target_relative = FALSE
  )
}

# NextBestMinDist ----

## class ----

#' `NextBestMinDist`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`NextBestMinDist`] is the class for next best dose that is based on minimum
#' distance to target probability.
#'
#' @slot target (`proportion`)\cr single target toxicity probability, except
#'   0 or 1.
#'
#' @aliases NextBestMinDist
#' @export
#'
.NextBestMinDist <- setClass(
  Class = "NextBestMinDist",
  slots = c(
    target = "numeric"
  ),
  prototype = prototype(
    target = 0.3
  ),
  contains = "NextBest",
  validity = v_next_best_min_dist
)

## constructor ----

#' @rdname NextBestMinDist-class
#'
#' @param target (`proportion`)\cr see slot definition.
#'
#' @export
#' @example examples/Rules-class-NextBestMinDist.R
#'
NextBestMinDist <- function(target) {
  .NextBestMinDist(target = target)
}

## default constructor ----

#' @rdname NextBestMinDist-class
#' @note Typically, end users will not use the `.DefaultNextBestMinDist()` function.
#' @export
.DefaultNextBestMinDist <- function() {
  NextBestMinDist(target = 0.3)
}

# NextBestInfTheory ----

## class ----

#' `NextBestInfTheory`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`NextBestInfTheory`] is the class for next best dose that is based on
#' information theory as proposed in https://doi.org/10.1002/sim.8450.
#'
#' @slot target (`proportion`)\cr target toxicity probability, except 0 or 1.
#' @slot asymmetry (`number`)\cr value of the asymmetry exponent in the
#'   divergence function that describes the rate of penalization for overly
#'   toxic does. It must be a value from \eqn{(0, 2)} interval.
#'
#' @aliases NextBestInfTheory
#' @export
#'
.NextBestInfTheory <- setClass(
  Class = "NextBestInfTheory",
  slots = c(
    target = "numeric",
    asymmetry = "numeric"
  ),
  prototype = prototype(
    target = 0.3,
    asymmetry = 1
  ),
  contains = "NextBest",
  validity = v_next_best_inf_theory
)

## constructor ----

#' @rdname NextBestInfTheory-class
#'
#' @param target (`proportion`)\cr see slot definition.
#' @param asymmetry (`number`)\cr see slot definition.
#'
#' @export
#'
NextBestInfTheory <- function(target, asymmetry) {
  .NextBestInfTheory(target = target, asymmetry = asymmetry)
}

## default constructor ----

#' @rdname NextBestInfTheory-class
#' @note Typically, end users will not use the `.DefaultNextBestInfTheory()` function.
#' @export
.DefaultNextBestInfTheory <- function() {
  NextBestInfTheory(0.33, 1.2)
}

# NextBestTD ----

## class ----

#' `NextBestTD`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`NextBestTD`] is the class to find a next best dose based on pseudo
#' DLT model without samples. Namely, it is to find two next best doses, one
#' for allocation during the trial and the second for final recommendation at
#' the end of a trial without involving any samples, i.e. only DLT responses
#' will be incorporated for the dose-allocation. This is based solely on the
#' probabilities of the occurrence of a DLT obtained by using the modal estimates
#' of the model parameters. There are two target probabilities of the
#' occurrence of a DLT that must be specified: target probability to be used
#' during the trial and target probability to be used at the end of the trial.
#' It is suitable to use it only with the [`ModelTox`] model class.
#'
#' @slot prob_target_drt (`proportion`)\cr the target probability (except 0 or 1)
#'   of the occurrence of a DLT to be used during the trial.
#' @slot prob_target_eot (`proportion`)\cr the target probability (except 0 or 1)
#'   of the occurrence of a DLT to be used at the end of the trial.
#'
#' @aliases NextBestTD
#' @export
#'
.NextBestTD <- setClass(
  Class = "NextBestTD",
  slots = c(
    prob_target_drt = "numeric",
    prob_target_eot = "numeric"
  ),
  prototype = prototype(
    prob_target_drt = 0.35,
    prob_target_eot = 0.3
  ),
  contains = "NextBest",
  validity = v_next_best_td
)

## default constructor ----

#' @rdname NextBestTD-class
#' @note Typically, end users will not use the `.DefaultNextBestTD()` function.
#' @export
.DefaultNextBestTD <- function() {
  NextBestTD(0.35, 0.3)
}

## constructor ----

#' @rdname NextBestTD-class
#'
#' @param prob_target_drt (`proportion`)\cr see slot definition.
#' @param prob_target_eot (`proportion`)\cr see slot definition.
#'
#' @export
#' @examples
#' my_next_best <- NextBestTD(0.35, 0.3)
NextBestTD <- function(prob_target_drt, prob_target_eot) {
  .NextBestTD(
    prob_target_drt = prob_target_drt,
    prob_target_eot = prob_target_eot
  )
}

# NextBestTDsamples ----

## class ----

#' `NextBestTDsamples`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`NextBestTDsamples`] is the class to find a next best dose based on Pseudo
#' DLT model with samples. Namely, it is to find two next best doses, one
#' for allocation during the trial and the second for final recommendation at
#' the end of a trial. Hence, there are two target probabilities of the
#' occurrence of a DLT that must be specified: target probability to be used
#' during the trial and target probability to be used at the end of the trial.
#'
#' @slot derive (`function`)\cr derives, based on a vector of posterior dose
#'   samples, the target dose that has the probability of the occurrence of
#'   DLT equals to either the `prob_target_drt` or `prob_target_eot`. It must
#'   therefore accept one and only one argument, which is a numeric vector, and
#'   return a number.
#'
#' @aliases NextBestTDsamples
#' @export
#'
.NextBestTDsamples <- setClass(
  Class = "NextBestTDsamples",
  slots = c(
    derive = "function"
  ),
  prototype = prototype(
    derive = function(dose_samples) {
      quantile(dose_samples, prob = 0.3)
    }
  ),
  contains = "NextBestTD",
  validity = v_next_best_td_samples
)

## constructor ----

#' @rdname NextBestTDsamples-class
#'
#' @param prob_target_drt (`proportion`)\cr see slot definition in [`NextBestTD`].
#' @param prob_target_eot (`proportion`)\cr see slot definition in [`NextBestTD`].
#' @param derive (`function`)\cr see slot definition.
#'
#' @export
#' @example examples/Rules-class-NextBestTDsamples.R
#'
NextBestTDsamples <- function(prob_target_drt, prob_target_eot, derive) {
  .NextBestTDsamples(
    prob_target_drt = prob_target_drt,
    prob_target_eot = prob_target_eot,
    derive = derive
  )
}

## default constructor ----

#' @rdname NextBestTDsamples-class
#' @note Typically, end users will not use the `.DefaultNextBestTDsamples()` function.
#' @export
.DefaultNextBestTDsamples <- function() {
  NextBestTDsamples(
    prob_target_drt = 0.35,
    prob_target_eot = 0.3,
    derive = function(samples) {
      as.numeric(quantile(samples, probs = 0.3))
    }
  )
}


# NextBestMaxGain ----

## class ----

#' `NextBestMaxGain`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`NextBestMaxGain`] is the class to find a next best dose with maximum gain
#' value based on a pseudo DLT and efficacy models without samples. It is based
#' solely on the probabilities of the occurrence of a DLT and the values
#' of the mean efficacy responses obtained by using the modal estimates of the
#' DLT and efficacy model parameters. There are two target probabilities of the
#' occurrence of a DLT that must be specified: target probability to be used
#' during the trial and target probability to be used at the end of the trial.
#' It is suitable to use it only with the [`ModelTox`] model and [`ModelEff`]
#' classes (except [`EffFlexi`]).
#'
#' @slot prob_target_drt (`proportion`)\cr the target probability of the
#'   occurrence of a DLT to be used during the trial.
#' @slot prob_target_eot (`proportion`)\cr the target probability of the
#'   occurrence of a DLT to be used at the end of the trial.
#'
#' @aliases NextBestMaxGain
#' @export
#'
.NextBestMaxGain <- setClass(
  Class = "NextBestMaxGain",
  slots = c(
    prob_target_drt = "numeric",
    prob_target_eot = "numeric"
  ),
  prototype = prototype(
    prob_target_drt = 0.35,
    prob_target_eot = 0.3
  ),
  contains = "NextBest",
  validity = v_next_best_td
)

## constructor ----

#' @rdname NextBestMaxGain-class
#'
#' @param prob_target_drt (`proportion`)\cr see slot definition.
#' @param prob_target_eot (`proportion`)\cr see slot definition.
#'
#' @export
#' @examples
#' my_next_best <- NextBestMaxGain(0.35, 0.3)
NextBestMaxGain <- function(prob_target_drt, prob_target_eot) {
  .NextBestMaxGain(
    prob_target_drt = prob_target_drt,
    prob_target_eot = prob_target_eot
  )
}

## default constructor ----

#' @rdname NextBestMaxGain-class
#' @note Typically, end users will not use the `.DefaultNextBestMaxGain()` function.
#' @export
.DefaultNextBestMaxGain <- function() {
  NextBestMaxGain(0.35, 0.3)
}

# NextBestMaxGainSamples ----

## class ----

#' `NextBestMaxGainSamples`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`NextBestMaxGainSamples`] is the class to find a next best dose with maximum
#' gain value based on a pseudo DLT and efficacy models and DLT and efficacy
#' samples. There are two target probabilities of the occurrence of a DLT that
#' must be specified: target probability to be used during the trial and target
#' probability to be used at the end of the trial.
#' It is suitable to use it only with the [`ModelTox`] model and [`ModelEff`]
#' classes.
#'
#' @slot derive (`function`)\cr derives, based on a vector of posterior dose
#'   samples, the target dose that has the probability of the occurrence of
#'   DLT equals to either the `prob_target_drt` or `prob_target_eot`. It must
#'   therefore accept one and only one argument, which is a numeric vector, and
#'   return a number.
#' @slot mg_derive (`function`)\cr derives, based on a vector of posterior dose
#'   samples that give the maximum gain value, the final next best estimate of
#'   the dose that gives the maximum gain value. It must therefore accept one
#'   and only one argument, which is a numeric vector, and return a number.
#'
#' @aliases NextBestMaxGainSamples
#' @export
#'
.NextBestMaxGainSamples <- setClass(
  Class = "NextBestMaxGainSamples",
  slots = c(
    derive = "function",
    mg_derive = "function"
  ),
  prototype = prototype(
    prob_target_drt = 0.35,
    prob_target_eot = 0.3,
    derive = function(dose_samples) {
      as.numeric(quantile(dose_samples, prob = 0.3))
    },
    mg_derive = function(dose_samples) {
      as.numeric(quantile(dose_samples, prob = 0.5))
    }
  ),
  contains = "NextBestMaxGain",
  validity = v_next_best_max_gain_samples
)

## constructor ----

#' @rdname NextBestMaxGainSamples-class
#'
#' @param prob_target_drt (`proportion`)\cr see slot definition in [`NextBestMaxGain`].
#' @param prob_target_eot (`proportion`)\cr see slot definition in [`NextBestMaxGain`].
#' @param derive (`function`)\cr see slot definition.
#' @param mg_derive (`function`)\cr see slot definition.
#'
#' @export
#' @example examples/Rules-class-NextBestMaxGainSamples.R
#'
NextBestMaxGainSamples <- function(prob_target_drt,
                                   prob_target_eot,
                                   derive,
                                   mg_derive) {
  .NextBestMaxGainSamples(
    prob_target_drt = prob_target_drt,
    prob_target_eot = prob_target_eot,
    derive = derive,
    mg_derive = mg_derive
  )
}

## default constructor ----

#' @rdname NextBestMaxGainSamples-class
#' @note Typically, end users will not use the `.DefaultNextBestMaxGainSamples()` function.
#' @export
.DefaultNextBestMaxGainSamples <- function() {
  NextBestMaxGainSamples(
    prob_target_drt = 0.35,
    prob_target_eot = 0.3,
    derive = function(samples) {
      as.numeric(quantile(samples, prob = 0.3))
    },
    mg_derive = function(mg_samples) {
      as.numeric(quantile(mg_samples, prob = 0.5))
    }
  )
}

# NextBestProbMTDLTE ----

## class ----

#' `NextBestProbMTDLTE`
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' [`NextBestProbMTDLTE`] is the class of finding a next best dose that selects
#' the dose with the highest probability of having a toxicity rate less or equal
#' to the toxicity target.
#' The dose is determined by calculating the posterior toxicity probability
#' for each dose per iteration and select the maximum dose that has a toxicity
#' probability below or equal to the target. The dose with the highest frequency
#' of being selected as MTD across iterations is the next best dose. Placebo
#' is not considered in the calculation and removed from the dose grid for
#' any calculations.
#'
#' @slot target (`numeric`)\cr the target toxicity probability.
#'
#' @aliases NextBestProbMTDLTE
#' @export
#'
.NextBestProbMTDLTE <- setClass(
  Class = "NextBestProbMTDLTE",
  slots = c(target = "numeric"),
  prototype = prototype(target = 0.3),
  contains = "NextBest",
  validity = v_next_best_prob_mtd_lte
)

## constructor ----

#' @rdname NextBestProbMTDLTE-class
#'
#' @param target (`numeric`)\cr see slot definition.
#' @export
#' @example examples/Rules-class-NextBestProbMTDLTE.R
#'
NextBestProbMTDLTE <- function(target) {
  .NextBestProbMTDLTE(target = target)
}

## default constructor ----

#' @rdname NextBestProbMTDLTE-class
#' @note Typically, end users will not use the `.DefaultNextBestProbMTDLTE()` function.
#' @export
.DefaultNextBestProbMTDLTE <- function() {
  NextBestProbMTDLTE(target = 0.3)
}

# NextBestProbMTDMinDist ----

## class ----

#' `NextBestProbMTDMinDist`
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' [`NextBestProbMTDMinDist`] is the class of finding a next best dose that selects
#' the dose with the highest probability of having a toxicity rate with the
#' smallest distance to the toxicity target.
#' The dose is determined by calculating the posterior toxicity probability
#' for each dose per iteration and select the dose that has the smallest toxicity
#' probability distance to the target. The dose with the highest frequency
#' of being selected as MTD across iterations is the next best dose. Placebo
#' is not considered as the next dose and for that reason not used in
#' calculations. I.e. for placebo the toxicity probability distance to target
#' is not calculated and taken into account for determination of the next dose.
#'
#' @slot target (`numeric`)\cr the target toxicity probability.
#'
#' @aliases NextBestProbMTDMinDist
#' @export
#'
.NextBestProbMTDMinDist <- setClass(
  Class = "NextBestProbMTDMinDist",
  slots = c(target = "numeric"),
  prototype = prototype(target = 0.3),
  contains = "NextBest",
  validity = v_next_best_prob_mtd_min_dist
)

## constructor ----

#' @rdname NextBestProbMTDMinDist-class
#'
#' @param target (`numeric`)\cr see slot definition.
#' @export
#' @example examples/Rules-class-NextBestProbMTDMinDist.R
#'
NextBestProbMTDMinDist <- function(target) {
  .NextBestProbMTDMinDist(target = target)
}

## default constructor ----

#' @rdname NextBestProbMTDMinDist-class
#' @note Typically, end users will not use the `.DefaultNextBestProbMTDMinDist()` function.
#' @export
.DefaultNextBestProbMTDMinDist <- function() {
  NextBestProbMTDMinDist(target = 0.3)
}

# NextBestOrdinal ----

## class ----

#' `NextBestOrdinal`
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' [`NextBestOrdinal`] is the class for applying a standard `NextBest` rule to
#' the results of an ordinal CRM trial.
#'
#' @slot grade (`integer`)\cr the toxicity grade to which the `rule` should be
#' applied.
#' @slot rule (`NextBest`)\cr the standard `NextBest` rule to be applied
#'
#' @aliases NextBestOrdinal
#' @export
#'
.NextBestOrdinal <- setClass(
  Class = "NextBestOrdinal",
  slots = c(grade = "numeric", rule = "NextBest"),
  contains = "NextBest",
  validity = v_next_best_ordinal
)

## constructor ----

#' @rdname NextBestOrdinal-class
#'
#' @param grade (`numeric`)\cr see slot definition.
#' @param rule (`NextBest`)\cr see slot definition.
#' @export
#' @example examples/Rules-class-NextBestOrdinal.R
#'
NextBestOrdinal <- function(grade, rule) {
  .NextBestOrdinal(grade = grade, rule = rule)
}

## default constructor ----

#' @rdname NextBestOrdinal-class
#' @note Typically, end users will not use the `.DefaultNextBestOrdinal()` function.
#' @export
.DefaultNextBestOrdinal <- function() {
  NextBestOrdinal(
    grade = 1L,
    rule = NextBestMTD(
      0.25,
      function(mtd_samples) {
        quantile(mtd_samples, probs = 0.25)
      }
    )
  )
}

# Increments ----

## class ----

#' `Increments`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`Increments`] is a virtual class for controlling increments, from which all
#' other specific increments classes inherit.
#'
#' @seealso [`IncrementsRelative`], [`IncrementsRelativeDLT`],
#'   [`IncrementsDoseLevels`], [`IncrementsHSRBeta`], [`IncrementsMin`].
#'
#' @aliases Increments
#' @export
#'
setClass(
  Class = "Increments",
  contains = "CrmPackClass"
)

## default constructor ----

#' @rdname Increments-class
#' @note Typically, end users will not use the `.DefaultIncrements()` function.
#' @export
.DefaultIncrements <- function() {
  stop(paste0("Class Increments cannot be instantiated directly.  Please use one of its subclasses instead."))
}


# IncrementsRelative ----

## class ----

#' `IncrementsRelative`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`IncrementsRelative`] is the class for increments control based on relative
#' differences in intervals.
#'
#' @slot intervals (`numeric`)\cr a vector with the left bounds of the relevant
#'   intervals. For example, `intervals  = c(0, 50, 100)` specifies three intervals:
#'   \eqn{(0, 50)}, \eqn{[50, 100)} and \eqn{[100, +Inf)}. That means, the right
#'   bound of the intervals are exclusive to the interval and the last interval
#'   goes from the last value to infinity.
#' @slot increments (`numeric`)\cr a vector of the same length with the maximum
#'   allowable relative increments in the `intervals`.
#'
#' @aliases IncrementsRelative
#' @export
#'
.IncrementsRelative <- setClass(
  Class = "IncrementsRelative",
  slots = c(
    intervals = "numeric",
    increments = "numeric"
  ),
  prototype = prototype(
    intervals = c(0, 2),
    increments = c(2, 1)
  ),
  contains = "Increments",
  validity = v_increments_relative
)

## constructor ----

#' @rdname IncrementsRelative-class
#'
#' @param intervals (`numeric`)\cr see slot definition.
#' @param increments (`numeric`)\cr see slot definition.
#'
#' @export
#' @example examples/Rules-class-IncrementsRelative.R
#'
IncrementsRelative <- function(intervals, increments) {
  .IncrementsRelative(
    intervals = intervals,
    increments = increments
  )
}

## default constructor ----

#' @rdname IncrementsRelative-class
#' @note Typically, end users will not use the `.DefaultIncrementsRelative()` function.
#' @export
.DefaultIncrementsRelative <- function() {
  IncrementsRelative(intervals = c(0, 20), increments = c(1, 0.33))
}


# IncrementsRelativeDLT ----

## class ----

#' `IncrementsRelativeDLT`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`IncrementsRelativeDLT`] is the class for increments control based on
#' relative differences in terms of DLTs.
#'
#' @slot intervals (`integer`)\cr a vector with the left bounds of the
#'   relevant DLT intervals. For example, `intervals  = c(0, 1, 3)` specifies
#'   three intervals (sets of DLTs: first, 0 DLT; second 1 or 2 DLTs; and the third
#'   one, at least 3 DLTs. That means, the right bound of the intervals are
#'   exclusive to the interval and the last interval goes from the last value to
#'   infinity.
#' @slot increments (`numeric`)\cr a vector of maximum allowable relative
#'   increments corresponding to `intervals`. IT must be of the same length
#'   as the length of `intervals`.
#'
#' @note This considers all DLTs across all cohorts observed so far.
#'
#' @seealso [IncrementsRelativeDLTCurrent] which only considers the DLTs
#'   in the current cohort.
#'
#' @aliases IncrementsRelativeDLT
#' @export
#'
.IncrementsRelativeDLT <- setClass(
  Class = "IncrementsRelativeDLT",
  slots = representation(
    intervals = "integer",
    increments = "numeric"
  ),
  prototype = prototype(
    intervals = c(0L, 1L),
    increments = c(2, 1)
  ),
  contains = "Increments",
  validity = v_increments_relative_dlt
)

## constructor ----

#' @rdname IncrementsRelativeDLT-class
#'
#' @param intervals (`numeric`)\cr see slot definition.
#' @param increments (`numeric`)\cr see slot definition.
#'
#' @export
#' @example examples/Rules-class-IncrementsRelativeDLT.R
#'
IncrementsRelativeDLT <- function(intervals, increments) {
  assert_integerish(intervals, lower = 0, any.missing = FALSE)
  assert_numeric(increments, any.missing = FALSE, lower = 0)

  .IncrementsRelativeDLT(
    intervals = as.integer(intervals),
    increments = increments
  )
}

## default constructor ----

#' @rdname IncrementsRelativeDLT-class
#' @note Typically, end users will not use the `.DefaultIncrementsRelativeDLT()` function.
#' @export
.DefaultIncrementsRelativeDLT <- function() {
  IncrementsRelativeDLT(intervals = c(0L, 1L, 3L), increments = c(1, 0.33, 0.2))
}

# IncrementsRelativeDLTCurrent ----

## class ----

#' `IncrementsRelativeDLTCurrent`
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' [`IncrementsRelativeDLTCurrent`] is the class for increments control based on
#' relative differences and current DLTs. The class is based on the number of
#' DLTs observed in the current cohort, but not cumulatively over all cohorts
#' so far.
#'
#' @seealso [IncrementsRelativeDLT].
#'
#' @aliases IncrementsRelativeDLTCurrent
#' @export
#'
.IncrementsRelativeDLTCurrent <- setClass(
  Class = "IncrementsRelativeDLTCurrent",
  contains = "IncrementsRelativeDLT"
)

## constructor ----

#' @rdname IncrementsRelativeDLTCurrent-class
#'
#' @inheritParams IncrementsRelativeDLT
#'
#' @export
#' @example examples/Rules-class-IncrementsRelativeDLTCurrent.R
#'
IncrementsRelativeDLTCurrent <- function(intervals = c(0L, 1L),
                                         increments = c(2L, 1L)) {
  assert_integerish(intervals, lower = 0, any.missing = FALSE)
  assert_numeric(increments, any.missing = FALSE, lower = 0)

  .IncrementsRelativeDLTCurrent(
    intervals = as.integer(intervals),
    increments = increments
  )
}

## default constructor ----

#' @rdname IncrementsRelativeDLTCurrent-class
#' @note Typically, end users will not use the `.DefaultIncrementsRelativeDLTCurrent()` function.
#' @export
.DefaultIncrementsRelativeDLTCurrent <- function() { # nolint
  IncrementsRelativeDLTCurrent(intervals = c(0L, 1L, 3L), increments = c(1, 0.33, 0.2))
}

# IncrementsRelativeParts ----

## class ----

#' `IncrementsRelativeParts`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`IncrementsRelativeParts`] is the class for increments control based on
#' relative differences in intervals, with special rules for part 1 and
#' beginning of part 2.
#'
#' @details This class works only in conjunction with [`DataParts`] objects. If
#' part 2 will just be started in the next cohort, then the next maximum dose
#' will be either `dlt_start` (e.g. -1) shift of the last part 1 dose in case
#' of a DLT in part 1, or `clean_start` shift (e.g. -1) in case of no DLTs in
#' part 1, given that `clean_start <= 0` (see description of `clean_start`
#' slot for more details). If part 1 will still be on in the next cohort,
#' then the next dose level will be the next higher dose level in the
#' `part1Ladder` slot of the data object. If part 2 has been started before,
#' the usual relative increment rules apply, see [`IncrementsRelative`].
#'
#' @slot dlt_start (`integer`)\cr a scalar, the dose level increment for starting
#'   part 2 in case of at least one DLT event in part 1.
#' @slot clean_start (`integer`)\cr a scalar, the dose level increment for
#'   starting part 2 in case of no DLTs in part 1. If `clean_start <= 0`,
#'   then the part 1 ladder will be used to find the maximum next dose.
#'   Otherwise, the relative increment rules will be applied to find the next
#'   maximum dose level.
#'
#' @note We require that `clean_start >= dlt_start`. However, this precondition
#'   is not a prerequisite for any function (except of the class' validation
#'   function) that works with objects of this class. It is rather motivated by
#'   the semantics. That is, if we observe a DLT in part 1, we cannot be more
#'   aggressive than in case of a clean part 1 without DLT.
#'
#' @aliases IncrementsRelativeParts
#' @export
#'
.IncrementsRelativeParts <- setClass(
  Class = "IncrementsRelativeParts",
  slots = representation(
    dlt_start = "integer",
    clean_start = "integer"
  ),
  prototype = prototype(
    dlt_start = -1L,
    clean_start = 1L
  ),
  contains = "IncrementsRelative",
  validity = v_increments_relative_parts
)

## constructor ----

#' @rdname IncrementsRelativeParts-class
#'
#' @param dlt_start (`count`)\cr see slot definition.
#' @param clean_start (`count`)\cr see slot definition.
#' @inheritDotParams IncrementsRelative
#'
#' @export
#' @example examples/Rules-class-IncrementsRelative-DataParts.R
#'
IncrementsRelativeParts <- function(dlt_start, clean_start, ...) {
  assert_integerish(dlt_start)
  assert_integerish(clean_start)

  .IncrementsRelativeParts(
    dlt_start = as.integer(dlt_start),
    clean_start = as.integer(clean_start),
    ...
  )
}

## default constructor ----

#' @rdname IncrementsRelativeParts-class
#' @note Typically, end users will not use the `.DefaultIncrementsRelativeParts()` function.
#' @export
.DefaultIncrementsRelativeParts <- function() {
  IncrementsRelativeParts(dlt_start = 0L, clean_start = 1L)
}

# IncrementsDoseLevels ----

## class ----

#' `IncrementsDoseLevels`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`IncrementsDoseLevels`] is the class for increments control based on the
#' number of dose levels.
#'
#' @slot levels (`count`)\cr maximum number of dose levels to increment for
#'   the next dose. It defaults to 1, which means that no dose skipping is
#'   allowed, i.e. the next dose can be maximum one level higher than the current
#'   base dose. The current base dose level is the dose level used to increment
#'   from (see `basis_level` parameter).
#' @slot basis_level (`string`)\cr defines the current base dose level. It can
#'   take one out of two possible values: `last` or `max`.
#'   If `last` is specified (default), the current base dose level is set to the
#'   last dose given. If `max` is specified, then the current base dose level is
#'   set to the maximum dose level given.
#'
#' @aliases IncrementsDoseLevels
#' @export
#'
.IncrementsDoseLevels <- setClass(
  Class = "IncrementsDoseLevels",
  slots = representation(
    levels = "integer",
    basis_level = "character"
  ),
  prototype = prototype(
    levels = 1L,
    basis_level = "last"
  ),
  contains = "Increments",
  validity = v_increments_dose_levels
)

## constructor ----

#' @rdname IncrementsDoseLevels-class
#'
#' @param levels (`count`)\cr see slot definition.
#' @param basis_level (`string`)\cr see slot definition.
#'
#' @export
#' @example examples/Rules-class-IncrementsDoseLevels.R
#'
IncrementsDoseLevels <- function(levels = 1L, basis_level = "last") {
  assert_count(levels, positive = TRUE)
  assert_string(basis_level)
  assert_subset(basis_level, c("last", "max"))

  .IncrementsDoseLevels(
    levels = as.integer(levels),
    basis_level = basis_level
  )
}

## default constructor ----

#' @rdname IncrementsDoseLevels-class
#' @note Typically, end users will not use the `.DefaultIncrementsDoseLevels()` function.
#' @export
.DefaultIncrementsDoseLevels <- function() {
  IncrementsDoseLevels(levels = 2L, basis_level = "last")
}

# IncrementsHSRBeta ----

## class ----

#' `IncrementsHSRBeta`
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' [`IncrementsHSRBeta`] is a class for limiting further increments using
#' a Hard Safety Rule based on the Bin-Beta model.
#' Increment control is based on the number of observed DLTs and number of
#' subjects at each dose level. The probability of toxicity is calculated
#' using a Bin-Beta model with prior (a,b). If the probability exceeds
#' the threshold for a given dose, that dose and all doses above are excluded
#' from further escalation.
#' This is a hard safety rule that limits further escalation based on the
#' observed data per dose level, independent from the underlying model.
#'
#' @slot target (`proportion`)\cr the target toxicity, except
#'   0 or 1.
#' @slot prob (`proportion`)\cr the threshold probability (except 0 or 1) for
#'   a dose being toxic.
#' @slot a (`number`)\cr shape parameter \eqn{a > 0} of probability distribution
#'   Beta (a,b).
#' @slot b (`number`)\cr shape parameter \eqn{b > 0} of probability distribution
#'   Beta (a,b).
#'
#' @aliases IncrementsHSRBeta
#' @export
#'
.IncrementsHSRBeta <- setClass(
  Class = "IncrementsHSRBeta",
  slots = c(
    target = "numeric",
    prob = "numeric",
    a = "numeric",
    b = "numeric"
  ),
  prototype = prototype(
    target = 0.3,
    prob = 0.95,
    a = 1,
    b = 1
  ),
  contains = "Increments",
  validity = v_increments_hsr_beta
)

## constructor ----

#' @rdname IncrementsHSRBeta-class
#'
#' @param target (`proportion`)\cr see slot definition.
#' @param prob (`proportion`)\cr see slot definition.
#' @param a (`number`)\cr see slot definition.
#' @param b (`number`)\cr see slot definition.
#'
#' @example examples/Rules-class-IncrementsHSRBeta.R
#' @export
#'
IncrementsHSRBeta <- function(target = 0.3,
                              prob = 0.95,
                              a = 1,
                              b = 1) {
  .IncrementsHSRBeta(
    target = target,
    prob = prob,
    a = a,
    b = b
  )
}

## default constructor ----

#' @rdname IncrementsHSRBeta-class
#' @note Typically, end users will not use the `.DefaultIncrementsHSRBeta()` function.
#' @export
.DefaultIncrementsHSRBeta <- function() {
  IncrementsHSRBeta(target = 0.3, prob = 0.95)
}

# IncrementsMin ----

## class ----

#' `IncrementsMin`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`IncrementsMin`] is the class that combines multiple increment rules with
#' the `minimum` operation. Slot `increments_list` contains all increment rules,
#' which are itself the objects of class [`Increments`]. The minimum of these
#' individual increments is taken to give the final maximum increment.
#'
#' @slot increments_list (`list`)\cr list with increment rules.
#'
#' @aliases IncrementsMin
#' @export
#'
.IncrementsMin <- setClass(
  Class = "IncrementsMin",
  slots = c(increments_list = "list"),
  prototype = prototype(
    increments_list = list(
      IncrementsRelativeDLT(intervals = c(0L, 1L), increments = c(2, 1)),
      IncrementsRelative(intervals = c(0, 2), increments = c(2, 1))
    )
  ),
  contains = "Increments",
  validity = v_increments_min
)

## constructor ----

#' @rdname IncrementsMin-class
#'
#' @param increments_list (`list`)\cr see slot definition.
#'
#' @example examples/Rules-class-IncrementsMin.R
#' @export
#'
IncrementsMin <- function(increments_list) {
  .IncrementsMin(increments_list = increments_list)
}
## default constructor ----

#' @rdname IncrementsMin-class
#' @note Typically, end users will not use the `.DefaultIncrementsMin()` function.
#' @export
.DefaultIncrementsMin <- function() {
  IncrementsMin(
    increments_list = list(
      IncrementsRelativeDLT(intervals = c(0, 1, 3), increments = c(1, 0.33, 0.2)),
      IncrementsRelative(intervals = c(0, 20), increments = c(1, 0.33))
    )
  )
}

# IncrementsOrdinal ----

## class ----

#' `IncrementsOrdinal`
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' [`IncrementsOrdinal`] is the class for applying a standard `Increments` rule to
#' the results of an ordinal CRM trial.
#'
#' @slot grade (`integer`)\cr the toxicity grade to which the `rule` should be
#' applied.
#' @slot rule (`Increments`)\cr the standard `Increments` rule to be applied
#'
#' @aliases IncrementsOrdinal
#' @export
#'
.IncrementsOrdinal <- setClass(
  Class = "IncrementsOrdinal",
  slots = c(grade = "numeric", rule = "Increments"),
  contains = "Increments",
  validity = v_increments_ordinal
)

## constructor ----

#' @rdname IncrementsOrdinal-class
#'
#' @param grade (`numeric`)\cr see slot definition.
#' @param rule (`Increments`)\cr see slot definition.
#' @export
#' @example examples/Rules-class-IncrementsOrdinal.R
#'
IncrementsOrdinal <- function(grade, rule) {
  .IncrementsOrdinal(grade = grade, rule = rule)
}

## default constructor ----

#' @rdname IncrementsOrdinal-class
#' @note Typically, end users will not use the `.DefaultIncrementsOrdinal()` function.
#' @export
.DefaultIncrementsOrdinal <- function() {
  IncrementsOrdinal(
    grade = 1L,
    rule = IncrementsRelative(intervals = c(0, 20), increments = c(1, 0.33))
  )
}

# Stopping ----

## class ----

#' `Stopping`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`Stopping`] is a class for stopping rules.
#'
#' @slot report_label (`string`)\cr a label for the stopping report. The meaning
#'   of this parameter is twofold. If it is equal to `NA_character_` (default),
#'   the `report_label` will not be used in the report at all. Otherwise, if it
#'   is specified as an empty character (i.e. `character(0)`) in a user constructor,
#'   then a default, class-specific label will be created for this slot.
#'   Finally, for the remaining cases, a user can provide a custom label.
#'
#' @seealso [`StoppingList`], [`StoppingCohortsNearDose`], [`StoppingPatientsNearDose`],
#'   [`StoppingMinCohorts`], [`StoppingMinPatients`], [`StoppingTargetProb`],
#'   [`StoppingMTDdistribution`], [`StoppingTargetBiomarker`], [`StoppingHighestDose`]
#'   [`StoppingMTDCV`], [`StoppingLowestDoseHSRBeta`], [`StoppingSpecificDose`].
#'
#' @aliases Stopping
#' @export
#'
setClass(
  Class = "Stopping",
  contains = "CrmPackClass",
  slots = c(report_label = "character"),
  prototype = prototype(report_label = character(0))
)


## default constructor ----

#' @rdname CohortSize-class
#' @note Typically, end users will not use the `DefaultCohortSize()` function.
#' @export
.DefaultCohortSize <- function() {
  stop(paste0("Class CohortSize should not be instantiated directly.  Please use one of its subclasses instead."))
}

# StoppingMissingDose ----

## class ----

#' `StoppingMissingDose`
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' [`StoppingMissingDose`] is the class for stopping based on NA returned by
#'  next best dose.
#'
#' @aliases StoppingMissingDose
#' @export
#'
.StoppingMissingDose <- setClass(
  Class = "StoppingMissingDose",
  contains = "Stopping"
)

## constructor ----

#' @rdname StoppingMissingDose-class
#' @param report_label (`string` or `NA`)\cr see slot definition.
#' @example examples/Rules-class-StoppingMissingDose.R
#' @export
#'
StoppingMissingDose <- function(
    report_label = NA_character_) {
  report_label <- h_default_if_empty(
    as.character(report_label),
    paste("Stopped because of missing dose")
  )

  .StoppingMissingDose(report_label = report_label)
}

## default constructor ----

#' @rdname StoppingMissingDose-class
#' @note Typically, end users will not use the `.DefaultStoppingMissingDose()` function.
#' @export
#'
.DefaultStoppingMissingDose <- function() {
  StoppingMissingDose()
}

# StoppingCohortsNearDose ----

## class ----

#' `StoppingCohortsNearDose`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`StoppingCohortsNearDose`] is the class for stopping based on number of
#' cohorts near to next best dose.
#'
#'
#' @slot nCohorts (`number`)\cr number of required cohorts.
#' @slot percentage (`number`)\cr percentage (between and including 0 and 100)
#'   within the next best dose the cohorts must lie.
#'
#' @aliases StoppingCohortsNearDose
#' @export
#'
.StoppingCohortsNearDose <- setClass(
  Class = "StoppingCohortsNearDose",
  slots = c(
    nCohorts = "integer",
    percentage = "numeric"
  ),
  prototype = prototype(
    nCohorts = 2L,
    percentage = 50
  ),
  contains = "Stopping",
  validity = v_stopping_cohorts_near_dose
)

## constructor ----

#' @rdname StoppingCohortsNearDose-class
#'
#' @param nCohorts (`number`)\cr see slot definition.
#' @param percentage (`number`)\cr see slot definition.
#' @param report_label (`string` or `NA`)\cr see slot definition.
#'
#' @example examples/Rules-class-StoppingCohortsNearDose.R
#' @export
#'
StoppingCohortsNearDose <- function(nCohorts = 2L,
                                    percentage = 50,
                                    report_label = NA_character_) {
  assert_count(nCohorts, positive = TRUE)
  assert_numeric(percentage, lower = 0)

  report_label <- h_default_if_empty(
    as.character(report_label),
    paste("\u2265", nCohorts, "cohorts dosed in", percentage, "% dose range around NBD")
  )

  .StoppingCohortsNearDose(
    nCohorts = as.integer(nCohorts),
    percentage = percentage,
    report_label = report_label
  )
}

## default constructor ----

#' @rdname StoppingCohortsNearDose-class
#' @note Typically, end users will not use the `.DefaultStoppingCohortsNearDose()` function.
#' @export
.DefaultStoppingCohortsNearDose <- function() { # nolint
  StoppingCohortsNearDose(
    nCohorts = 3L,
    percentage = 0.2
  )
}


# StoppingPatientsNearDose ----

## class ----

#' `StoppingPatientsNearDose`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`StoppingPatientsNearDose`] is the class for stopping based on number of
#' patients near to next best dose.
#'
#' @slot nPatients (`number`)\cr number of required patients.
#' @slot percentage (`number`)\cr percentage (between and including 0 and 100)
#'   within the next best dose the patients must lie.
#'
#' @aliases StoppingPatientsNearDose
#' @export
#'
.StoppingPatientsNearDose <- setClass(
  Class = "StoppingPatientsNearDose",
  slots = c(
    nPatients = "integer",
    percentage = "numeric"
  ),
  prototype = prototype(
    nPatients = 10L,
    percentage = 50
  ),
  contains = "Stopping",
  validity = v_stopping_patients_near_dose
)

## constructor ----

#' @rdname StoppingPatientsNearDose-class
#'
#' @param nPatients (`number`)\cr see slot definition.
#' @param percentage (`number`)\cr see slot definition.
#' @param report_label (`string` or `NA`)\cr see slot definition.
#'
#' @example examples/Rules-class-StoppingPatientsNearDose.R
#' @export
#'
StoppingPatientsNearDose <- function(nPatients = 10L,
                                     percentage = 50,
                                     report_label = NA_character_) {
  assert_count(nPatients, positive = TRUE)
  assert_number(percentage, lower = 0, upper = 100)

  report_label <- h_default_if_empty(
    as.character(report_label),
    paste("\u2265", nPatients, "patients dosed in", percentage, "% dose range around NBD")
  )

  .StoppingPatientsNearDose(
    nPatients = as.integer(nPatients),
    percentage = percentage,
    report_label = report_label
  )
}

## default constructor ----

#' @rdname StoppingPatientsNearDose-class
#' @note Typically, end users will not use the `.DefaultStoppingPatientsNearDose()` function.
#' @export
.DefaultStoppingPatientsNearDose <- function() { # nolint
  StoppingPatientsNearDose(
    nPatients = 9L,
    percentage = 20,
    report_label = NA_character_
  )
}

# StoppingMinCohorts ----

## class ----

#' `StoppingMinCohorts`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`StoppingMinCohorts`] is the class for stopping based on minimum number of
#' cohorts.
#'
#' @slot nCohorts (`number`)\cr minimum required number of cohorts.
#'
#' @aliases StoppingMinCohorts
#' @export
#'
.StoppingMinCohorts <- setClass(
  Class = "StoppingMinCohorts",
  slots = c(nCohorts = "integer"),
  prototype = prototype(nCohorts = 2L),
  contains = "Stopping",
  validity = v_stopping_min_cohorts
)

## constructor ----

#' @rdname StoppingMinCohorts-class
#'
#' @param nCohorts (`number`)\cr see slot definition.
#' @param report_label (`string` or `NA`)\cr see slot definition.
#'
#' @example examples/Rules-class-StoppingMinCohorts.R
#' @export
#'
StoppingMinCohorts <- function(nCohorts = 2L,
                               report_label = NA_character_) {
  assert_count(nCohorts, positive = TRUE)

  report_label <- h_default_if_empty(
    as.character(report_label),
    paste("\u2265", nCohorts, "cohorts dosed")
  )

  .StoppingMinCohorts(
    nCohorts = as.integer(nCohorts),
    report_label = report_label
  )
}

## default constructor ----

#' @rdname StoppingMinCohorts-class
#' @note Typically, end users will not use the `.DefaultStoppingMinCohorts()` function.
#' @export
.DefaultStoppingMinCohorts <- function() {
  StoppingMinCohorts(
    nCohorts = 6L
  )
}

# StoppingMinPatients ----

## class ----

#' `StoppingMinPatients`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`StoppingMinPatients`] is the class for stopping based on minimum number of
#' patients
#'
#' @slot nPatients (`number`)\cr minimum allowed number of patients.
#'
#' @aliases StoppingMinPatients
#' @export
#'
.StoppingMinPatients <- setClass(
  Class = "StoppingMinPatients",
  slots = c(nPatients = "integer"),
  prototype = prototype(nPatients = 20L),
  contains = "Stopping",
  validity = v_stopping_min_patients
)

## constructor ----

#' @rdname StoppingMinPatients-class
#'
#' @param nPatients (`number`)\cr see slot definition.
#' @param report_label (`string` or `NA`)\cr see slot definition.
#'
#' @example examples/Rules-class-StoppingMinPatients.R
#' @export
#'
StoppingMinPatients <- function(nPatients = 20L,
                                report_label = NA_character_) {
  assert_count(nPatients, positive = TRUE)

  report_label <- h_default_if_empty(
    as.character(report_label),
    paste("\u2265", nPatients, "patients dosed")
  )

  .StoppingMinPatients(
    nPatients = as.integer(nPatients),
    report_label = report_label
  )
}

## default constructor ----

#' @rdname StoppingMinPatients-class
#' @note Typically, end users will not use the `.DefaultStoppingMinPatients()` function.
#' @export
.DefaultStoppingMinPatients <- function() {
  StoppingMinPatients(
    nPatients = 20L
  )
}

# StoppingTargetProb ----

## class ----

#' `StoppingTargetProb`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`StoppingTargetProb`] is the class for stopping based on the probability of
#' the DLT rate being in the target toxicity interval.
#'
#' @slot target (`number`)\cr the target toxicity interval, e.g. `c(0.2, 0.35)`.
#' @slot prob (`proportion`)\cr required target toxicity probability (except 0 or 1)
#'   for reaching sufficient precision.
#'
#' @aliases StoppingTargetProb
#' @export
#'
.StoppingTargetProb <- setClass(
  Class = "StoppingTargetProb",
  slots = c(
    target = "numeric",
    prob = "numeric"
  ),
  prototype = prototype(
    target = c(0.2, 0.35),
    prob = 0.4
  ),
  contains = "Stopping",
  validity = v_stopping_target_prob
)

## constructor ----

#' @rdname StoppingTargetProb-class
#'
#' @param target (`number`)\cr see slot definition.
#' @param prob (`proportion`)\cr see slot definition.
#' @param report_label (`string` or `NA`)\cr see slot definition.
#'
#' @example examples/Rules-class-StoppingTargetProb.R
#' @export
#'
StoppingTargetProb <- function(target = c(0.2, 0.35),
                               prob = 0.4,
                               report_label = NA_character_) {
  assert_numeric(target, len = 2)
  report_label <- h_default_if_empty(
    as.character(report_label),
    paste0("P(", target[1], " \u2264 prob(DLE | NBD) \u2264 ", target[2], ") \u2265 ", prob)
  )

  .StoppingTargetProb(
    target = target,
    prob = prob,
    report_label = report_label
  )
}

## default constructor ----

#' @rdname StoppingTargetProb-class
#' @note Typically, end users will not use the `.DefaultStoppingTargetProb()` function.
#' @export
.DefaultStoppingTargetProb <- function() {
  StoppingTargetProb(
    target = c(0.2, 0.35),
    prob = 0.5
  )
}

# StoppingMTDdistribution ----

## class ----

#' `StoppingMTDdistribution`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`StoppingMTDdistribution`] is the class for stopping based on the posterior
#' distribution of the MTD. It is used for the cases where the stopping occurs
#' when the probability of `MTD > thresh * next_dose` is greater than or equal
#' to `prob`, where the `next_dose` is the recommended next best dose.
#' Here, the MTD is defined as the dose that reaches a specific `target`
#' probability of the occurrence of a DLT.
#'
#' @slot target (`proportion`)\cr the target toxicity probability (except 0 or 1)
#'   defining the MTD.
#' @slot thresh (`proportion`)\cr the threshold (except 0 or 1) relative to the
#'   recommended next best dose.
#' @slot prob (`proportion`)\cr required minimum probability, except 0 or 1.
#'
#' @aliases StoppingMTDdistribution
#' @export
#'
.StoppingMTDdistribution <- setClass(
  Class = "StoppingMTDdistribution",
  slots = c(
    target = "numeric",
    thresh = "numeric",
    prob = "numeric"
  ),
  prototype = prototype(
    target = 0.33,
    thresh = 0.5,
    prob = 0.9
  ),
  contains = "Stopping",
  validity = v_stopping_mtd_distribution
)

## constructor ----

#' @rdname StoppingMTDdistribution-class
#'
#' @param target (`proportion`)\cr see slot definition.
#' @param thresh (`proportion`)\cr see slot definition.
#' @param prob (`proportion`)\cr see slot definition.
#' @param report_label (`string` or `NA`)\cr see slot definition.
#'
#' @example examples/Rules-class-StoppingMTDdistribution.R
#' @export
#'
StoppingMTDdistribution <- function(target = 0.33,
                                    thresh = 0.5,
                                    prob = 0.9,
                                    report_label = NA_character_) {
  report_label <- h_default_if_empty(
    as.character(report_label),
    paste0("P(MTD > ", thresh, " * NBD | P(DLE) = ", target, ") \u2265 ", prob)
  )

  .StoppingMTDdistribution(
    target = target,
    thresh = thresh,
    prob = prob,
    report_label = report_label
  )
}

## default constructor ----

#' @rdname StoppingMTDdistribution-class
#' @note Typically, end users will not use the `.DefaultStoppingMTDDistribution()` function.
#' @export
.DefaultStoppingMTDdistribution <- function() {
  StoppingMTDdistribution(
    target = 0.33,
    thresh = 0.5,
    prob = 0.9
  )
}

# StoppingMTDCV ----

## class ----

#' `StoppingMTDCV`
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' [`StoppingMTDCV`] is a class for stopping rule based on precision of MTD
#' which is calculated as the coefficient of variation (CV) of the MTD.
#' Here, the MTD is defined as the dose that reaches a specific `target`
#' probability of the occurrence of a DLT.
#'
#' @slot target (`proportion`)\cr toxicity target of MTD (except 0 or 1).
#' @slot thresh_cv (`number`)\cr threshold (percentage > 0) for CV to be
#'   considered accurate enough to stop the trial. The stopping occurs when the
#'   CV is less than or equal to `tresh_cv`.
#'
#' @aliases StoppingMTDCV
#' @export
#'
.StoppingMTDCV <- setClass(
  Class = "StoppingMTDCV",
  slots = c(
    target = "numeric",
    thresh_cv = "numeric"
  ),
  prototype = prototype(
    target = 0.3,
    thresh_cv = 40
  ),
  contains = "Stopping",
  validity = v_stopping_mtd_cv
)

## constructor ----

#' @rdname StoppingMTDCV-class
#'
#' @param target (`proportion`)\cr see slot definition.
#' @param thresh_cv (`number`)\cr see slot definition.
#' @param report_label (`string` or `NA`)\cr see slot definition.
#'
#' @export
#' @example examples/Rules-class-StoppingMTDCV.R
#'
StoppingMTDCV <- function(target = 0.3,
                          thresh_cv = 40,
                          report_label = NA_character_) {
  report_label <- h_default_if_empty(
    as.character(report_label),
    paste("CV(MTD) >", target)
  )

  .StoppingMTDCV(
    target = target,
    thresh_cv = thresh_cv,
    report_label = report_label
  )
}

## default constructor ----

#' @rdname StoppingMTDCV-class
#' @note Typically, end users will not use the `.DefaultStoppingMTDCV()` function.
#'
#' @export
.DefaultStoppingMTDCV <- function() {
  StoppingMTDCV(
    target = 0.3,
    thresh_cv = 40
  )
}

# StoppingLowestDoseHSRBeta ----

## class ----

#' `StoppingLowestDoseHSRBeta`
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' [`StoppingLowestDoseHSRBeta`] is a class for stopping based on a Hard Safety
#' Rule using the Beta posterior distribution with Beta(a,b) prior and a
#' Bin-Beta model based on the observed data at the lowest dose level.
#' The rule is triggered when the first dose is considered to be toxic
#' (i.e. above threshold probability) based on the observed data at the
#' lowest dose level and a Beta(a,b) prior distribution.
#' The default prior is Beta(1,1).
#' In case that placebo is used, the rule is evaluated at the second dose of the
#' dose grid, i.e. at the lowest non-placebo dose.
#'
#' @note This stopping rule is independent from the underlying model.
#'
#' @slot target (`proportion`)\cr the target toxicity.
#' @slot prob (`proportion`)\cr the threshold probability for the lowest dose
#'   being toxic.
#' @slot a (`number`)\cr shape parameter \eqn{a > 0} of probability distribution
#'   Beta (a,b).
#' @slot b (`number`)\cr shape parameter \eqn{b > 0} of probability distribution
#'   Beta (a,b).
#'
#' @aliases StoppingLowestDoseHSRBeta
#' @export
#'
.StoppingLowestDoseHSRBeta <- setClass(
  Class = "StoppingLowestDoseHSRBeta",
  slots = c(
    target = "numeric",
    prob = "numeric",
    a = "numeric",
    b = "numeric"
  ),
  prototype = prototype(
    target = 0.3,
    prob = 0.95,
    a = 1,
    b = 1
  ),
  contains = "Stopping",
  validity = v_increments_hsr_beta
)

## constructor ----

#' @rdname StoppingLowestDoseHSRBeta-class
#'
#' @param target (`proportion`)\cr see slot definition.
#' @param prob (`proportion`)\cr see slot definition.
#' @param a (`number`)\cr see slot definition.
#' @param b (`number`)\cr see slot definition.
#' @param report_label (`string` or `NA`)\cr see slot definition.
#'
#' @export
#' @example examples/Rules-class-StoppingLowestDoseHSRBeta.R
#'
StoppingLowestDoseHSRBeta <- function(target = 0.3,
                                      prob = 0.95,
                                      a = 1,
                                      b = 1,
                                      report_label = NA_character_) {
  report_label <- h_default_if_empty(
    as.character(report_label),
    paste0("P\u03B2(lowest dose > P(DLE) = ", target, ") > ", prob)
  )

  .StoppingLowestDoseHSRBeta(
    target = target,
    prob = prob,
    a = a,
    b = b,
    report_label = report_label
  )
}

## default constructor ----

#' @rdname StoppingLowestDoseHSRBeta-class
#' @note Typically, end users will not use the `.DefaultStoppingLowestDoseHSRBeta()` function.
#' @export
.DefaultStoppingLowestDoseHSRBeta <- function() { # nolint
  StoppingLowestDoseHSRBeta(
    target = 0.3,
    prob = 0.95,
    a = 1,
    b = 1
  )
}

# StoppingTargetBiomarker ----

## class ----

#' `StoppingTargetBiomarker`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`StoppingTargetBiomarker`] is a class for stopping based on probability of
#' target biomarker.
#'
#' @slot target (`numeric`)\cr the biomarker target range that needs to be
#'   reached. For example, `target = c(0.8, 1.0)` with `is_relative = TRUE`
#'   means that we target a dose with at least 80% of maximum biomarker level.
#' @slot is_relative (`flag`)\cr is target relative? If it so (default), then
#'   the `target` is interpreted relative to the maximum, so it must be a
#'   probability range. Otherwise, the `target` is interpreted as absolute
#'   biomarker range.
#' @slot prob (`proportion`)\cr required target probability (except 0 or 1) for
#'   reaching sufficient precision.
#'
#' @aliases StoppingTargetBiomarker
#' @export
#'
.StoppingTargetBiomarker <- setClass(
  Class = "StoppingTargetBiomarker",
  slots = c(
    target = "numeric",
    is_relative = "logical",
    prob = "numeric"
  ),
  prototype = prototype(
    target = c(0.9, 1),
    is_relative = TRUE,
    prob = 0.3
  ),
  contains = "Stopping",
  validity = v_stopping_target_biomarker
)

## constructor ----

#' @rdname StoppingTargetBiomarker-class
#'
#' @param target (`numeric`)\cr see slot definition.
#' @param prob (`proportion`)\cr see slot definition.
#' @param is_relative (`flag`)\cr see slot definition.
#' @param report_label (`string` or `NA`)\cr see slot definition.
#'
#' @export
#' @example examples/Rules-class-StoppingTargetBiomarker.R
#'
StoppingTargetBiomarker <- function(target = c(0.9, 1),
                                    prob = 0.3,
                                    is_relative = TRUE,
                                    report_label = NA_character_) {
  assert_numeric(target, len = 2)
  assert_flag(is_relative)

  report_label <- h_default_if_empty(
    as.character(report_label),
    paste0(
      "P(", target[1], " \u2264 ", "Biomarker \u2264 ", target[2], ") \u2265 ", prob,
      ifelse(is_relative, " (relative)", " (absolute)")
    )
  )

  .StoppingTargetBiomarker(
    target = target,
    is_relative = is_relative,
    prob = prob,
    report_label = report_label
  )
}

## default constructor ----

#' @rdname StoppingTargetBiomarker-class
#' @note Typically, end users will not use the `.DefaultStoppingTargetBiomarker()` function.
#' @export
.DefaultStoppingTargetBiomarker <- function() {
  StoppingTargetBiomarker(
    target = c(0.9, 1),
    prob = 0.5,
    is_relative = TRUE
  )
}

# StoppingSpecificDose ----

## class ----

#' `StoppingSpecificDose`
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' [`StoppingSpecificDose`] is the class for testing a stopping rule at specific
#' dose of the dose grid and not at the next best dose.
#'
#' @slot rule (`Stopping`)\cr a stopping rule available in this package.
#' @slot dose (`positive_number`)\cr a dose that is defined as part of the dose
#'   grid of the data.
#'
#' @aliases StoppingSpecificDose
#' @export
#'
.StoppingSpecificDose <- setClass(
  Class = "StoppingSpecificDose",
  slots = c(
    rule = "Stopping",
    dose = "positive_number"
  ),
  contains = "Stopping"
)

## constructor ----

#' @rdname StoppingSpecificDose-class
#'
#' @param rule (`Stopping`)\cr see slot definition.
#' @param dose (`number`)\cr see slot definition.
#' @param report_label (`string` or `NA`) \cr see slot definition.
#'
#' @export
#' @example examples/Rules-class-StoppingSpecificDose.R
#'
StoppingSpecificDose <- function(rule = StoppingTargetProb(target = c(0, 0.3), prob = 0.8),
                                 dose = 80,
                                 report_label = NA_character_) {
  report_label <- h_default_if_empty(
    as.character(report_label),
    paste0("Dose ", dose, " used for testing a stopping rule")
  )

  .StoppingSpecificDose(
    rule = rule,
    dose = positive_number(dose),
    report_label = report_label
  )
}

## default constructor ----

#' @rdname StoppingSpecificDose-class
#' @note Typically, end users will not use the `.DefaultStoppingSpecificDose()` function.
#' @export
.DefaultStoppingSpecificDose <- function() {
  StoppingSpecificDose(
    rule = StoppingTargetProb(target = c(0, 0.3), prob = 0.8),
    dose = positive_number(80)
  )
}

# StoppingHighestDose ----

## class ----

#' `StoppingHighestDose`
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' [`StoppingHighestDose`] is the class for stopping based on the highest dose.
#' That is, the stopping occurs when the highest dose is reached.
#'
#' @aliases StoppingHighestDose
#' @export
#'
.StoppingHighestDose <- setClass(
  Class = "StoppingHighestDose",
  contains = "Stopping"
)

## constructor ----

#' @rdname StoppingHighestDose-class
#' @param report_label (`string` or `NA`)\cr see slot definition.
#'
#' @export
#' @example examples/Rules-class-StoppingHighestDose.R
#'
StoppingHighestDose <- function(report_label = NA_character_) {
  report_label <- h_default_if_empty(
    as.character(report_label),
    "NBD is the highest dose"
  )

  .StoppingHighestDose(report_label = report_label)
}

## default constructor ----

#' @rdname StoppingHighestDose-class
#' @note Typically, end users will not use the `.DefaultStoppingHighestDose()` function.
#' @export
.DefaultStoppingHighestDose <- function() {
  StoppingHighestDose()
}

# StoppingTDCIRatio ----

## class ----

#' `StoppingTDCIRatio`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`StoppingTDCIRatio`] is the class for testing a stopping rule that is based
#' on a target ratio of the 95% credibility interval. Specifically, this is the
#' ratio of the upper to the lower bound of the 95% credibility interval's
#' estimate of the target dose (i.e. a dose that corresponds to a given target
#' probability of the occurrence of a DLT `prob_target`).
#'
#' @slot target_ratio (`numeric`)\cr target for the ratio of the 95% credibility
#'   interval's estimate, that is required to stop a trial.
#' @slot prob_target (`proportion`)\cr the target probability of the occurrence
#'   of a DLT.
#'
#' @aliases StoppingTDCIRatio
#' @export
#'
.StoppingTDCIRatio <- setClass(
  Class = "StoppingTDCIRatio",
  slots = c(
    target_ratio = "numeric",
    prob_target = "numeric"
  ),
  prototype = prototype(
    target_ratio = 5,
    prob_target = 0.3
  ),
  contains = "Stopping",
  validity = v_stopping_tdci_ratio
)

## constructor ----

#' @rdname StoppingTDCIRatio-class
#'
#' @param target_ratio (`numeric`)\cr see slot definition.
#' @param prob_target (`proportion`)\cr see slot definition.
#' @param report_label (`string` or `NA`)\cr see slot definition.
#'
#' @export
#' @example examples/Rules-class-StoppingTDCIRatio.R
#'
StoppingTDCIRatio <- function(target_ratio = 5,
                              prob_target = 0.3,
                              report_label = NA_character_) {
  report_label <- h_default_if_empty(
    as.character(report_label),
    paste("TD", target_ratio, "for", prob_target, "target prob")
  )

  .StoppingTDCIRatio(
    target_ratio = target_ratio,
    prob_target = prob_target,
    report_label = report_label
  )
}

## default constructor ----

#' @rdname StoppingTDCIRatio-class
#' @note Typically, end users will not use the `.DefaultStoppingTDCIRatio()` function.
#' @export
.DefaultStoppingTDCIRatio <- function() {
  StoppingTDCIRatio(
    target_ratio = 5,
    prob_target = 0.3
  )
}

# StoppingMaxGainCIRatio ----

## class ----

#' `StoppingMaxGainCIRatio`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`StoppingMaxGainCIRatio`] is the class for testing a stopping rule that is based
#' on a target ratio of the 95% credibility interval. Specifically, this is the
#' ratio of the upper to the lower bound of the 95% credibility interval's
#' estimate of the:
#' (1) target dose (i.e. a dose that corresponds to a given target
#' probability of the occurrence of a DLT `prob_target`), or
#' (2) max gain dose (i.e. a dose which gives the maximum gain),
#' depending on which one out of these two is smaller.
#'
#' @slot target_ratio (`numeric`)\cr target for the ratio of the 95% credibility
#'   interval's estimate, that is required to stop a trial.
#' @slot prob_target (`proportion`)\cr the target probability of the occurrence
#'   of a DLT.
#'
#' @aliases StoppingMaxGainCIRatio
#' @export
#'
.StoppingMaxGainCIRatio <- setClass(
  Class = "StoppingMaxGainCIRatio",
  slots = c(
    target_ratio = "numeric",
    prob_target = "numeric"
  ),
  prototype = prototype(
    target_ratio = 5,
    prob_target = 0.3
  ),
  contains = "Stopping",
  validity = v_stopping_tdci_ratio
)

## constructor ----

#' @rdname StoppingMaxGainCIRatio-class
#'
#' @param target_ratio (`numeric`)\cr see slot definition.
#' @param prob_target (`proportion`)\cr see slot definition.
#' @param report_label (`string` or `NA`)\cr see slot definition.
#'
#' @export
#' @example examples/Rules-class-StoppingMaxGainCIRatio.R
#'
StoppingMaxGainCIRatio <- function(target_ratio = 5,
                                   prob_target = 0.3,
                                   report_label = NA_character_) {
  report_label <- h_default_if_empty(
    as.character(report_label),
    paste("GStar", target_ratio, "for", prob_target, "target prob")
  )

  .StoppingMaxGainCIRatio(
    target_ratio = target_ratio,
    prob_target = prob_target,
    report_label = report_label
  )
}


## default constructor ----

#' @rdname StoppingMaxGainCIRatio-class
#' @examples
#' .DefaultStoppingMaxGainCIRatio()
#' @export
.DefaultStoppingMaxGainCIRatio <- function() {
  StoppingMaxGainCIRatio(
    target_ratio = 5,
    prob_target = 0.3
  )
}



# StoppingList ----

## class ----

#' `StoppingList`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`StoppingList`] is the class for testing a stopping rule that consists of
#' many single stopping rules that are in turn the objects of class `Stopping`.
#' The `summary` slot stores a function that takes a logical vector of the size
#' of `stop_list` and returns a single logical value. For example, if the function
#' `all` is specified as a `summary` function, then that all stopping rules
#' defined in `stop_list` must be satisfied in order the result of this rule to
#' be `TRUE`.
#'
#' @slot stop_list (`list`)\cr list of stopping rules.
#' @slot summary (`function`)\cr a summary function to combine the results of
#'   the stopping rules into a single result.
#'
#' @aliases StoppingList
#' @export
#'
.StoppingList <- setClass(
  Class = "StoppingList",
  slots = c(
    stop_list = "list",
    summary = "function"
  ),
  prototype = prototype(
    stop_list = list(StoppingMinPatients(50), StoppingMinCohorts(5)),
    summary = all
  ),
  contains = "Stopping",
  validity = v_stopping_list
)

## constructor ----

#' @rdname StoppingList-class
#'
#' @param stop_list (`list`)\cr see slot definition.
#' @param summary (`function`)\cr see slot definition.
#'
#' @export
#' @example examples/Rules-class-StoppingList.R
#'
StoppingList <- function(stop_list, summary) {
  .StoppingList(
    stop_list = stop_list,
    summary = summary
  )
}

## default constructor ----

#' @rdname StoppingList-class
#' @note Typically, end users will not use the `.DefaultStoppingList()` function.
#' @export
.DefaultStoppingList <- function() {
  StoppingList(
    stop_list = c(
      StoppingMinCohorts(nCohorts = 3L),
      StoppingTargetProb(target = c(0.2, 0.35), prob = 0.5),
      StoppingMinPatients(nPatients = 20L)
    ),
    summary = any
  )
}

# StoppingAll ----

## class ----

#' `StoppingAll`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`StoppingAll`] is the class for testing a stopping rule that consists of
#' many single stopping rules that are in turn the objects of class `Stopping`.
#' All single stopping rules must be satisfied in order the result of this rule
#' to be `TRUE`.
#'
#' @slot stop_list (`list`)\cr list of stopping rules.
#' @slot report_label label for reporting
#' @aliases StoppingAll
#' @export
#'
.StoppingAll <- setClass(
  Class = "StoppingAll",
  slots = c(
    stop_list = "list"
  ),
  prototype = prototype(
    stop_list = list(
      StoppingMinPatients(50),
      StoppingMinCohorts(5)
    )
  ),
  contains = "Stopping",
  validity = v_stopping_all
)

## constructor ----

#' @rdname StoppingAll-class
#'
#' @param stop_list (`list`)\cr see slot definition.
#' @param report_label (`string`) \cr see slot definition.
#' @export
#' @example examples/Rules-class-StoppingAll.R
#'
StoppingAll <- function(stop_list, report_label = NA_character_) {
  .StoppingAll(
    stop_list = stop_list,
    report_label = report_label
  )
}
## default constructor ----

#' @rdname StoppingAll-class
#' @note Typically, end users will not use the `.DefaultStoppingAll()` function.
#' @export
.DefaultStoppingAll <- function() {
  StoppingAll(
    stop_list = c(
      StoppingMinCohorts(nCohorts = 3L),
      StoppingTargetProb(target = c(0.2, 0.35), prob = 0.5),
      StoppingMinPatients(nPatients = 20L)
    )
  )
}

# StoppingAny ----

## class ----

#' `StoppingAny`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`StoppingAny`] is the class for testing a stopping rule that consists of
#' many single stopping rules that are in turn the objects of class `Stopping`.
#' At least one single stopping rule must be satisfied in order the result of
#' this rule to be `TRUE`.
#'
#' @slot stop_list (`list`)\cr list of stopping rules.
#' @slot report_label label for reporting
#'
#' @aliases StoppingAny
#' @export
#'
.StoppingAny <- setClass(
  Class = "StoppingAny",
  slots = c(
    stop_list = "list"
  ),
  prototype = prototype(
    stop_list = list(StoppingMinPatients(50), StoppingMinCohorts(5))
  ),
  contains = "Stopping",
  validity = v_stopping_all
)

## constructor ----

#' @rdname StoppingAny-class
#'
#' @param stop_list (`list`)\cr see slot definition.
#' @param report_label (`string`)\cr see slot definition.
#'
#' @export
#' @example examples/Rules-class-StoppingAny.R
#'
StoppingAny <- function(stop_list, report_label = NA_character_) {
  .StoppingAny(
    stop_list = stop_list,
    report_label = report_label
  )
}

## default constructor ----

#' @rdname StoppingAny-class
#' @note Typically, end users will not use the `.DefaultStoppingAny()` function.
#' @export
.DefaultStoppingAny <- function() {
  StoppingAny(
    stop_list = c(
      StoppingMinCohorts(nCohorts = 3L),
      StoppingTargetProb(target = c(0.2, 0.35), prob = 0.5),
      StoppingMinPatients(nPatients = 20L)
    )
  )
}

# StoppingOrdinal ----

## class ----

#' `StoppingOrdinal`
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' [`StoppingOrdinal`] is the class for stopping based on a Stopping rule applied
#' to a specific toxicity grade in an ordinal CRM trial
#'
#' @slot grade (`integer`)\cr the grade to which the rule should be applied
#' @slot rule (`Stopping`)\cr the rule to apply
#'
#' @aliases StoppingOrdinal
#' @export
#'
.StoppingOrdinal <- setClass(
  Class = "StoppingOrdinal",
  slots = c(grade = "integer", rule = "Stopping"),
  contains = "Stopping"
)

## constructor ----

#' @rdname StoppingOrdinal-class
#' @param grade (`integer`)\cr see slot definition.
#' @param rule (`Stopping`)\cr see slot definition.
#' @example examples/Rules-class-StoppingOrdinal.R
#' @export
#'
StoppingOrdinal <- function(grade, rule) {
  .StoppingOrdinal(grade = grade, rule = rule)
}

## default constructor ----

#' @rdname StoppingOrdinal-class
#' @note Typically, end users will not use the `.DefaultStoppingOrdinal()` function.
#' @export
#'
.DefaultStoppingOrdinal <- function() {
  StoppingOrdinal(
    1L,
    StoppingTargetProb(target = c(0.2, 0.35), prob = 0.6)
  )
}

# CohortSize ----

## class ----

#' `CohortSize`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`CohortSize`] is a class for cohort sizes.
#'
#' @seealso [`CohortSizeRange`], [`CohortSizeDLT`], [`CohortSizeConst`],
#'   [`CohortSizeParts`], [`CohortSizeMin`], [`CohortSizeMin`].
#'
#' @aliases CohortSize
#' @export
#'
setClass(
  Class = "CohortSize",
  contains = "CrmPackClass"
)

## default constructor

#' @rdname CohortSize-class
#' @note Typically, end users will not use the `DefaultCohortSize()` function.
#' @export
.DefaultCohortSize <- function() {
  stop(paste0("Class CohortSize should not be instantiated directly.  Please use one of its subclasses instead."))
}

# CohortSizeRange ----

## class ----

#' `CohortSizeRange`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`CohortSizeRange`] is the class for cohort size based on dose range.
#'
#' @slot intervals (`numeric`)\cr a vector with the left bounds of the relevant
#'   dose intervals.
#' @slot cohort_size (`integer`)\cr an integer vector with the cohort sizes
#'   corresponding to the elements of `intervals`.
#'
#' @aliases CohortSizeRange
#' @export
#'
.CohortSizeRange <- setClass(
  Class = "CohortSizeRange",
  slots = c(
    intervals = "numeric",
    cohort_size = "integer"
  ),
  prototype = prototype(
    intervals = c(0, 20),
    cohort_size = c(1L, 3L)
  ),
  contains = "CohortSize",
  validity = v_cohort_size_range
)

## constructor ----

#' @rdname CohortSizeRange-class
#'
#' @param intervals (`numeric`)\cr see slot definition.
#' @param cohort_size (`numeric`)\cr see slot definition.
#'
#' @export
#' @example examples/Rules-class-CohortSizeRange.R
#'
CohortSizeRange <- function(intervals, cohort_size) {
  # Cohort size 0 is needed to allow for no-placebo designs
  assert_integerish(cohort_size, lower = 0, any.missing = FALSE)

  .CohortSizeRange(
    intervals = intervals,
    cohort_size = as.integer(cohort_size)
  )
}

## default constructor ----

#' @rdname CohortSizeRange-class
#' @note Typically, end users will not use the `.DefaultCohortSizeRange()` function.
#' @export
.DefaultCohortSizeRange <- function() {
  CohortSizeRange(intervals = c(0L, 30L), cohort_size = c(1L, 3L))
}

# CohortSizeDLT ----

## class ----

#' `CohortSizeDLT`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`CohortSizeDLT`] is the class for cohort size based on number of DLTs.

#' @slot intervals (`integer`)\cr a vector with the left bounds of the
#'   relevant DLT intervals.
#' @slot cohort_size (`integer`)\cr a vector with the cohort sizes corresponding
#'   to the elements of `intervals`.
#'
#' @aliases CohortSizeDLT
#' @export
#'
.CohortSizeDLT <- setClass(
  Class = "CohortSizeDLT",
  slots = c(
    intervals = "integer",
    cohort_size = "integer"
  ),
  prototype = prototype(
    intervals = c(0L, 1L),
    cohort_size = c(1L, 3L)
  ),
  contains = "CohortSize",
  validity = v_cohort_size_dlt
)

## constructor ----

#' @rdname CohortSizeDLT-class
#'
#' @param intervals (`numeric`)\cr see slot definition.
#' @param cohort_size (`numeric`)\cr see slot definition.
#'
#' @export
#' @example examples/Rules-class-CohortSizeDLT.R
#'
CohortSizeDLT <- function(intervals, cohort_size) {
  assert_integerish(intervals, lower = 0, any.missing = FALSE)
  # Cohort size 0 is needed to allow for no-placebo designs
  assert_integerish(cohort_size, lower = 0, any.missing = FALSE)

  .CohortSizeDLT(
    intervals = as.integer(intervals),
    cohort_size = as.integer(cohort_size)
  )
}

## default constructor ----

#' @rdname CohortSizeDLT-class
#' @note Typically, end users will not use the `.DefaultCohortSizeDLT()` function.
#' @export
.DefaultCohortSizeDLT <- function() {
  CohortSizeDLT(intervals = c(0L, 1L), cohort_size = c(1L, 3L))
}


# CohortSizeConst ----

## class ----

#' `CohortSizeConst`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`CohortSizeConst`] is the class for fixed and constant size of cohort.
#'
#' @slot size (`integer`)\cr cohort size.
#'
#' @aliases CohortSizeConst
#' @export
#'
.CohortSizeConst <- setClass(
  Class = "CohortSizeConst",
  slots = c(size = "integer"),
  prototype = prototype(size = 3L),
  contains = "CohortSize",
  validity = v_cohort_size_const
)

## constructor ----

#' @rdname CohortSizeConst-class
#'
#' @param size (`number`)\cr see slot definition.
#'
#' @export
#' @example examples/Rules-class-CohortSizeConst.R
#'
CohortSizeConst <- function(size) {
  # Cohort size 0 is needed to allow for no-placebo designs
  assert_integerish(size, lower = 0)
  .CohortSizeConst(size = as.integer(size))
}

## default constructor ----

#' @rdname CohortSizeConst-class
#' @note Typically, end users will not use the `.DefaultCohortSizeConst()` function.
#' @export
.DefaultCohortSizeConst <- function() {
  CohortSizeConst(size = 3L)
}

# CohortSizeParts ----

## class ----

#' `CohortSizeParts`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`CohortSizeParts`] is the class for cohort size that changes for the second
#' part of the dose escalation. It works only in conjunction with [`DataParts`]
#' objects.
#'
#' @slot cohort_sizes (`integer`)\cr a vector of length two with two sizes, one for
#'   part 1, and one for part 2 respectively.
#'
#' @aliases CohortSizeParts
#' @export
#'
.CohortSizeParts <- setClass(
  Class = "CohortSizeParts",
  slots = c(cohort_sizes = "integer"),
  prototype = prototype(cohort_sizes = c(1L, 3L)),
  contains = "CohortSize",
  validity = v_cohort_size_parts
)

## constructor ----

#' @rdname CohortSizeParts-class
#'
#' @param cohort_sizes (`numeric`)\cr see slot definition.
#'
#' @export
#' @example examples/Rules-class-CohortSizeParts.R
#'
CohortSizeParts <- function(cohort_sizes) {
  # Cohort size 0 is needed to allow for no-placebo designs
  assert_integerish(cohort_sizes, lower = 0, any.missing = FALSE)
  .CohortSizeParts(cohort_sizes = as.integer(cohort_sizes))
}

## default constructor ----

#' @rdname CohortSizeParts-class
#' @note Typically, end users will not use the `.DefaultCohortSizeParts()` function.
#' @export
.DefaultCohortSizeParts <- function() {
  CohortSizeParts(cohort_sizes = c(1L, 3L))
}

# CohortSizeMax ----

## class ----

#' `CohortSizeMax`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`CohortSizeMax`] is the class for cohort size that is based on maximum of
#' multiple cohort size rules. The `cohort_sizes` slot stores a set of cohort
#' size rules, which are again the objects of class [`CohortSize`]. The maximum
#' of these individual cohort sizes is taken to give the final cohort size.
#'
#' @slot cohort_sizes (`list`)\cr a list of cohort size rules, i.e. objects
#' of class [`CohortSize`].
#'
#' @aliases CohortSizeMax
#' @export
#'
.CohortSizeMax <- setClass(
  Class = "CohortSizeMax",
  slots = c(cohort_sizes = "list"),
  prototype = prototype(
    cohort_sizes = list(
      CohortSizeRange(intervals = c(0, 30), cohort_size = c(1, 3)),
      CohortSizeDLT(intervals = c(0, 1), cohort_size = c(1, 3))
    )
  ),
  contains = "CohortSize",
  validity = v_cohort_size_max
)

## default constructor ----

#' @rdname CohortSizeMax-class
#' @note Typically, end users will not use the `.DefaultCohortSizeMax()` function.
#'
#' @export
.DefaultCohortSizeMax <- function() {
  CohortSizeMax(
    cohort_sizes = list(
      CohortSizeRange(intervals = c(0, 10), cohort_size = c(1L, 3L)),
      CohortSizeDLT(intervals = c(0L, 1L), cohort_size = c(1L, 3L))
    )
  )
}

## constructor ----

#' @rdname CohortSizeMax-class
#'
#' @param cohort_sizes (`list`)\cr see slot definition.
#'
#' @export
#' @example examples/Rules-class-CohortSizeMax.R
#'
CohortSizeMax <- function(cohort_sizes) {
  .CohortSizeMax(cohort_sizes = cohort_sizes)
}

# CohortSizeMin ----

## class ----

#' `CohortSizeMin`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`CohortSizeMin`] is the class for cohort size that is based on minimum of
#' multiple cohort size rules. The `cohort_sizes` slot stores a set of cohort
#' size rules, which are again the objects of class [`CohortSize`]. The minimum
#' of these individual cohort sizes is taken to give the final cohort size.
#'
#' @slot cohort_sizes (`list`)\cr a list of cohort size rules, i.e. objects
#' of class [`CohortSize`].
#'
#' @aliases CohortSizeMin
#' @export
#'
.CohortSizeMin <- setClass(
  Class = "CohortSizeMin",
  slots = c(cohort_sizes = "list"),
  prototype = prototype(
    cohort_sizes =
      list(
        CohortSizeRange(intervals = c(0, 30), cohort_size = c(1, 3)),
        CohortSizeDLT(intervals = c(0, 1), cohort_size = c(1, 3))
      )
  ),
  contains = "CohortSize",
  validity = v_cohort_size_max
)

## constructor ----

#' @rdname CohortSizeMin-class
#'
#' @param cohort_sizes (`list`)\cr see slot definition.
#'
#' @export
#' @example examples/Rules-class-CohortSizeMin.R
#'
CohortSizeMin <- function(cohort_sizes) {
  .CohortSizeMin(cohort_sizes = cohort_sizes)
}

## default constructor ----

#' @rdname CohortSizeMin-class
#' @note Typically, end users will not use the `.DefaultCohortSizeMin()` function.
#' @export
.DefaultCohortSizeMin <- function() {
  CohortSizeMin(
    cohort_sizes = list(
      CohortSizeRange(intervals = c(0, 10), cohort_size = c(1L, 3L)),
      CohortSizeDLT(intervals = c(0L, 1L), cohort_size = c(1L, 3L))
    )
  )
}

# CohortSizeOrdinal ----

## class ----

#' `CohortSizeOrdinal`
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' [`CohortSizeOrdinal`] is the class for cohort size for an ordinal CRM trial.
#'
#' @slot grade (`integer`)\cr the grade at which the rule should be applied
#' @slot rule (`CohortSize`)\cr the `CohortSize` rule to apply.
#'
#' @aliases CohortSizeOrdinal
#' @export
#'
.CohortSizeOrdinal <- setClass(
  Class = "CohortSizeOrdinal",
  slots = c(
    grade = "integer",
    rule = "CohortSize"
  ),
  prototype = prototype(
    grade = 1L,
    rule = CohortSizeRange(intervals = c(0, 30), cohort_size = c(1L, 3L))
  ),
  contains = "CohortSize",
  validity = v_cohort_size_ordinal
)

## constructor ----

#' @rdname CohortSizeOrdinal-class
#'
#' @param grade (`integer`)\cr see slot definition.
#' @param rule (`CohortSize`)\cr see slot definition.
#'
#' @export
#' @example examples/Rules-class-CohortSizeOrdinal.R
#'
CohortSizeOrdinal <- function(grade, rule) {
  # Cohort size 0 is needed to allow for no-placebo designs
  assert_integer(grade, lower = 1, len = 1)
  assert_class(rule, "CohortSize")

  .CohortSizeOrdinal(grade = grade, rule = rule)
}

## default constructor ----

#' @rdname CohortSizeOrdinal-class
#' @note Typically, end users will not use the `.DefaultCohortSizeOrdinal()` function.
#' @export
.DefaultCohortSizeOrdinal <- function() {
  CohortSizeOrdinal(
    grade = 1L,
    rule = CohortSizeRange(intervals = c(0L, 30L), cohort_size = c(1L, 3L))
  )
}


# SafetyWindow ----

## class ----

#' `SafetyWindow`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`SafetyWindow`] is a class for safety window.
#'
#' @seealso [`SafetyWindowSize`], [`SafetyWindowConst`].
#'
#' @aliases SafetyWindow
#' @export
#'
setClass(
  Class = "SafetyWindow",
  contains = "CrmPackClass"
)

## default constructor ----

#' @rdname SafetyWindow-class
#' @note Typically, end users will not use the `.DefaultSafetyWindow()` function.
#' @export
.DefaultSafetyWindow <- function() {
  stop(paste0("Class SafetyWindow cannot be instantiated directly.  Please use one of its subclasses instead."))
}


# SafetyWindowSize ----

## class ----

#' `SafetyWindowSize`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`SafetyWindowSize`] is the class for safety window length based on cohort
#' size. This class is used to decide the rolling rule from the clinical
#' perspective.
#'
#' @slot gap (`list`)\cr observed period of the previous patient before
#'   the next patient can be dosed. This is used as follows. If for instance,
#'   the cohort size is 4 and we want to specify three time intervals between
#'   these four consecutive patients, i.e. 7 units of time between the 1st and
#'   the 2nd patient, 5 units between the 2nd and the 3rd one, and finally 3
#'   units between the 3rd and the 4th one, then,
#'   `gap` = `list(c(7L, 5L, 3L))`. Sometimes, we want that the interval
#'   only between the 1st and 2nd patient should be increased for the
#'   safety consideration and the rest time intervals should remain constant,
#'   regardless of what the cohort size is. Then, `gap` = `list(c(7L, 3L))`
#'   and the the package will automatically repeat the last element of the vector
#'   for the remaining time intervals.
#' @slot size (`integer`)\cr a vector with the left bounds of the
#'   relevant cohort size intervals. This is used as follows. For instance, when
#'   we want to change the `gap` based on the cohort size, i.e. the time
#'   interval between the 1st and 2nd patient = 9 units of time and the rest
#'   time intervals are of 5 units of time when the cohort size is equal to or
#'   larger than 4. And the time interval between the 1st and 2nd patient = 7 units
#'   of time and the rest time intervals are 3 units of time when the cohort size
#'   is smaller than 4, then we specify `size = c(0L, 4L)`. This means,
#'   the right bound of the intervals are exclusive to the interval, and the
#'   last interval goes from the last value until infinity.
#' @slot follow (`count`)\cr the period of time that each patient in the
#'   cohort needs to be followed before the next cohort opens.
#' @slot follow_min (`count`)\cr at least one patient in the cohort needs
#'   to be followed at the minimal follow up time.
#'
#' @aliases SafetyWindowSize
#' @export
#'
.SafetyWindowSize <- setClass(
  Class = "SafetyWindowSize",
  slots = c(
    gap = "list",
    size = "integer",
    follow = "integer",
    follow_min = "integer"
  ),
  prototype = prototype(
    gap = list(1:2, 1:2),
    size = c(1L, 3L),
    follow = 1L,
    follow_min = 1L
  ),
  contains = "SafetyWindow",
  validity = v_safety_window_size
)

## constructor ----

#' @rdname SafetyWindowSize-class
#'
#' @param gap see slot definition.
#' @param size see slot definition.
#' @param follow see slot definition.
#' @param follow_min see slot definition.
#'
#' @export
#' @example examples/Rules-class-SafetyWindowSize.R
#'
SafetyWindowSize <- function(gap,
                             size,
                             follow,
                             follow_min) {
  assert_integerish(follow, lower = 0)
  assert_integerish(follow_min, lower = 0)
  for (g in gap) {
    assert_integerish(g, lower = 0)
  }
  assert_integerish(size, lower = 0)
  if (follow > follow_min) {
    warning("The value of follow_min is typically larger than the value of follow")
  }
  gap <- lapply(gap, as.integer)
  .SafetyWindowSize(
    gap = gap,
    size = as.integer(size),
    follow = as.integer(follow),
    follow_min = as.integer(follow_min)
  )
}

## default constructor ----

#' @rdname SafetyWindowSize-class
#' @note Typically, end users will not use the `.DefaultSafetyWindowSize()` function.
#' @export
.DefaultSafetyWindowSize <- function() {
  SafetyWindowSize(
    gap = list(c(7, 3), c(9, 5)),
    size = c(1, 4),
    follow = 7,
    follow_min = 14
  )
}

# SafetyWindowConst ----

## class ----

#' `SafetyWindowConst`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`SafetyWindowConst`] is the class for safety window length and it is used
#' when the `gap` should be kept constant.
#'
#' @slot gap (`integer`)\cr a vector, the constant gap between patients.
#' @slot follow (`count`)\cr how long to follow each patient. The period of time
#'   that each patient in the cohort needs to be followed before the next cohort
#'   opens.
#' @slot follow_min (`count`)\cr minimum follow up. At least one patient in the
#'   cohort needs to be followed at the minimal follow up time.
#'
#' @aliases SafetyWindowConst
#' @export
#'
.SafetyWindowConst <- setClass(
  Class = "SafetyWindowConst",
  slots = c(
    gap = "integer",
    follow = "integer",
    follow_min = "integer"
  ),
  prototype = prototype(
    gap = 0L,
    follow = 1L,
    follow_min = 1L
  ),
  contains = "SafetyWindow",
  validity = v_safety_window_const
)

## constructor ----

#' @rdname SafetyWindowConst-class
#'
#' @param gap see slot definition.
#' @param follow see slot definition.
#' @param follow_min see slot definition.
#'
#' @export
#' @example examples/Rules-class-SafetyWindowConst.R
#'
SafetyWindowConst <- function(gap,
                              follow,
                              follow_min) {
  assert_integerish(follow, lower = 0)
  assert_integerish(follow_min, lower = 0)
  assert_integerish(gap, lower = 0)

  if (follow > follow_min) {
    warning("The value of follow_min is typically larger than the value of follow")
  }
  .SafetyWindowConst(
    gap = as.integer(gap),
    follow = as.integer(follow),
    follow_min = as.integer(follow_min)
  )
}

## default constructor ----

#' @rdname SafetyWindowConst-class
#' @note Typically, end users will not use the `.DefaultSafetyWindowConst()` function.
#' @export
.DefaultSafetyWindowConst <- function() {
  SafetyWindowConst(
    gap = c(7, 5, 3),
    follow = 7,
    follow_min = 14
  )
}

#' @include checkmate.R
#' @include Model-methods.R
#' @include Samples-class.R
#' @include Rules-class.R
#' @include helpers.R
#' @include helpers_rules.R
#' @include helpers_broom.R
NULL

# nextBest ----

## generic ----

#' Finding the Next Best Dose
#'
#' @description `r lifecycle::badge("stable")`
#'
#' A function that computes the recommended next best dose based on the
#' corresponding rule `nextBest`, the posterior `samples` from the `model` and
#' the underlying `data`.
#'
#' @param nextBest (`NextBest`)\cr the rule for the next best dose.
#' @param doselimit (`number`)\cr the maximum allowed next dose. If it is an
#'   infinity (default), then essentially no dose limit will be applied in the
#'   course of dose recommendation calculation.
#' @param samples (`Samples`)\cr posterior samples from `model` parameters given
#'   `data`.
#' @param model (`GeneralModel`)\cr model that was used to generate the samples.
#' @param data (`Data`)\cr data that was used to generate the samples.
#' @param ... additional arguments without method dispatch.
#'
#' @return A list with the next best dose recommendation  (element named `value`)
#'   from the grid defined in `data`, and a plot depicting this recommendation
#'   (element named `plot`). In case of multiple plots also an element
#'   named `singlePlots` is included. The `singlePlots` is itself a list with
#'   single plots. An additional list with elements describing the outcome
#'   of the rule can be contained too.
#'
#' @export
#'
setGeneric(
  name = "nextBest",
  def = function(nextBest, doselimit, samples, model, data, ...) {
    if (!missing(doselimit)) {
      assert_number(doselimit, lower = 0, finite = FALSE)
    }
    standardGeneric("nextBest")
  },
  valueClass = "list"
)

## NextBestMTD ----

#' @describeIn nextBest find the next best dose based on the MTD rule.
#'
#' @aliases nextBest-NextBestMTD
#'
#' @export
#' @example examples/Rules-method-nextBest-NextBestMTD.R
#'
setMethod(
  f = "nextBest",
  signature = signature(
    nextBest = "NextBestMTD",
    doselimit = "numeric",
    samples = "Samples",
    model = "GeneralModel",
    data = "Data"
  ),
  definition = function(nextBest, doselimit = Inf, samples, model, data, ...) {
    # Generate the MTD samples and derive the next best dose.
    dose_target_samples <- dose(x = nextBest@target, model, samples, ...)
    dose_target <- nextBest@derive(dose_target_samples)

    # Round to the next possible grid point.
    doses_eligible <- h_next_best_eligible_doses(data@doseGrid, doselimit, data@placebo)
    next_dose_level <- which.min(abs(doses_eligible - dose_target))
    next_dose <- doses_eligible[next_dose_level]

    # Create a plot.
    p <- ggplot(
      data = data.frame(x = dose_target_samples),
      aes(.data$x),
      fill = "grey50",
      colour = "grey50"
    ) +
      geom_density() +
      coord_cartesian(xlim = range(data@doseGrid)) +
      geom_vline(xintercept = dose_target, colour = "black", lwd = 1.1) +
      geom_text(
        data = data.frame(x = dose_target),
        aes(.data$x, 0),
        label = "Est",
        vjust = -0.5,
        hjust = 0.5,
        colour = "black",
        angle = 90
      ) +
      xlab("MTD") +
      ylab("Posterior density")

    if (is.finite(doselimit)) {
      p <- p +
        geom_vline(xintercept = doselimit, colour = "red", lwd = 1.1) +
        geom_text(
          data = data.frame(x = doselimit),
          aes(.data$x, 0),
          label = "Max",
          vjust = -0.5,
          hjust = -0.5,
          colour = "red",
          angle = 90
        )
    }

    p <- p +
      geom_vline(xintercept = next_dose, colour = "blue", lwd = 1.1) +
      geom_text(
        data = data.frame(x = next_dose),
        aes(.data$x, 0),
        label = "Next",
        vjust = -0.5,
        hjust = -1.5,
        colour = "blue",
        angle = 90
      )

    list(value = next_dose, plot = p)
  }
)

## NextBestNCRM ----

#' @describeIn nextBest find the next best dose based on the NCRM method. The
#'   additional element `probs` in the output's list contains the target and
#'   overdosing probabilities (across all doses in the dose grid) used in the
#'   derivation of the next best dose.
#'
#' @aliases nextBest-NextBestNCRM
#'
#' @export
#' @example examples/Rules-method-nextBest-NextBestNCRM.R
#'
setMethod(
  f = "nextBest",
  signature = signature(
    nextBest = "NextBestNCRM",
    doselimit = "numeric",
    samples = "Samples",
    model = "GeneralModel",
    data = "Data"
  ),
  definition = function(nextBest, doselimit = Inf, samples, model, data, ...) {
    # Matrix with samples from the dose-tox curve at the dose grid points.
    prob_samples <- sapply(data@doseGrid, prob, model = model, samples = samples, ...)

    # Estimates of posterior probabilities that are based on the prob. samples
    # which are within overdose/target interval.
    prob_overdose <- colMeans(h_in_range(prob_samples, nextBest@overdose, bounds_closed = c(FALSE, TRUE)))
    prob_target <- colMeans(h_in_range(prob_samples, nextBest@target))

    # Eligible grid doses after accounting for maximum possible dose and discarding overdoses.
    is_dose_eligible <- h_next_best_eligible_doses(data@doseGrid, doselimit, data@placebo, levels = TRUE) &
      (prob_overdose <= nextBest@max_overdose_prob)

    next_dose <- if (any(is_dose_eligible)) {
      # If maximum target probability is higher than some numerical threshold,
      # then take that level, otherwise stick to the maximum level that is OK.
      # next_best_level is relative to eligible doses.
      next_best_level <- ifelse(
        test = any(prob_target[is_dose_eligible] > 0.05),
        yes = which.max(prob_target[is_dose_eligible]),
        no = sum(is_dose_eligible)
      )
      data@doseGrid[is_dose_eligible][next_best_level]
    } else {
      NA_real_
    }

    # Build plots, first for the target probability.
    p1 <- ggplot() +
      geom_bar(
        data = data.frame(Dose = data@doseGrid, y = prob_target * 100),
        aes(x = .data$Dose, y = .data$y),
        stat = "identity",
        position = "identity",
        width = min(diff(data@doseGrid)) / 2,
        colour = "darkgreen",
        fill = "darkgreen"
      ) +
      coord_cartesian(ylim = c(0, 100)) +
      ylab(paste("Target probability [%]"))

    if (is.finite(doselimit)) {
      p1 <- p1 + geom_vline(xintercept = doselimit, lwd = 1.1, lty = 2, colour = "black")
    }

    if (any(is_dose_eligible)) {
      p1 <- p1 +
        geom_vline(xintercept = data@doseGrid[sum(is_dose_eligible)], lwd = 1.1, lty = 2, colour = "red") +
        geom_point(
          data = data.frame(x = next_dose, y = prob_target[is_dose_eligible][next_best_level] * 100 + 0.03),
          aes(x = x, y = y),
          size = 3,
          pch = 25,
          col = "red",
          bg = "red"
        )
    }

    # Second, for the overdosing probability.
    p2 <- ggplot() +
      geom_bar(
        data = data.frame(Dose = data@doseGrid, y = prob_overdose * 100),
        aes(x = .data$Dose, y = .data$y),
        stat = "identity",
        position = "identity",
        width = min(diff(data@doseGrid)) / 2,
        colour = "red",
        fill = "red"
      ) +
      geom_hline(yintercept = nextBest@max_overdose_prob * 100, lwd = 1.1, lty = 2, colour = "black") +
      ylim(c(0, 100)) +
      ylab("Overdose probability [%]")

    # Place them below each other.
    plot_joint <- gridExtra::arrangeGrob(p1, p2, nrow = 2)

    list(
      value = next_dose,
      plot = plot_joint,
      singlePlots = list(plot1 = p1, plot2 = p2),
      probs = cbind(
        dose = data@doseGrid,
        target = prob_target,
        overdose = prob_overdose
      )
    )
  }
)

## NextBestNCRM-DataParts ----

#' @describeIn nextBest find the next best dose based on the NCRM method when
#'   two parts trial is used.
#'
#' @aliases nextBest-NextBestNCRM-DataParts
#'
#' @export
#' @example examples/Rules-method-nextBest-NextBestNCRM-DataParts.R
#'
setMethod(
  f = "nextBest",
  signature = signature(
    nextBest = "NextBestNCRM",
    doselimit = "numeric",
    samples = "Samples",
    model = "GeneralModel",
    data = "DataParts"
  ),
  definition = function(nextBest, doselimit = Inf, samples, model, data, ...) {
    # Exception when we are in part I or about to start part II!
    if (all(data@part == 1L)) {
      # Propose the highest possible dose (assuming that the dose limit came
      # from reasonable increments rule, i.e. incrementsRelativeParts).
      if (is.infinite(doselimit)) {
        stop("A finite doselimit needs to be specified for Part I.")
      }
      list(value = doselimit, plot = NULL)
    } else {
      # Otherwise we will just do the standard thing.
      callNextMethod(nextBest, doselimit, samples, model, data, ...)
    }
  }
)

## NextBestNCRMLoss ----

#' @describeIn nextBest find the next best dose based on the NCRM method and
#'   loss function.
#'
#' @aliases nextBest-NextBestNCRMLoss
#'
#' @export
#' @example examples/Rules-method-nextBest-NextBestNCRMLoss.R
#'
setMethod("nextBest",
  signature = signature(
    nextBest = "NextBestNCRMLoss",
    doselimit = "numeric",
    samples = "Samples",
    model = "GeneralModel",
    data = "Data"
  ),
  definition = function(nextBest, doselimit = Inf, samples, model, data, ...) {
    # Matrix with samples from the dose-tox curve at the dose grid points.
    prob_samples <- sapply(data@doseGrid, prob, model = model, samples = samples, ...)
    # Compute probabilities to be in target and overdose tox interval.
    prob_underdosing <- colMeans(prob_samples < nextBest@target[1])
    prob_target <- colMeans(h_in_range(prob_samples, nextBest@target))
    prob_overdose <- colMeans(h_in_range(prob_samples, nextBest@overdose, bounds_closed = c(FALSE, TRUE)))
    prob_mean <- colMeans(prob_samples)
    prob_sd <- apply(prob_samples, 2, stats::sd)

    is_unacceptable_specified <- any(nextBest@unacceptable != c(1, 1))

    prob_mat <- if (!is_unacceptable_specified) {
      cbind(underdosing = prob_underdosing, target = prob_target, overdose = prob_overdose)
    } else {
      prob_unacceptable <- colMeans(
        h_in_range(prob_samples, nextBest@unacceptable, bounds_closed = c(FALSE, TRUE))
      )
      prob_excessive <- prob_overdose
      prob_overdose <- prob_excessive + prob_unacceptable
      cbind(
        underdosing = prob_underdosing,
        target = prob_target,
        excessive = prob_excessive,
        unacceptable = prob_unacceptable
      )
    }

    posterior_loss <- as.vector(nextBest@losses %*% t(prob_mat))
    names(posterior_loss) <- data@doseGrid

    probs <- cbind(
      dose = data@doseGrid,
      prob_mat = prob_mat,
      mean = prob_mean,
      std_dev = prob_sd,
      posterior_loss = posterior_loss
    )

    # Eligible grid doses after accounting for maximum possible dose and discarding overdoses.
    is_dose_eligible <- h_next_best_eligible_doses(data@doseGrid, doselimit, data@placebo, levels = TRUE) &
      (prob_overdose < nextBest@max_overdose_prob)

    # Next best dose is the dose with the minimum loss function.
    next_dose <- if (any(is_dose_eligible)) {
      next_best_level <- which.min(posterior_loss[is_dose_eligible])
      data@doseGrid[is_dose_eligible][next_best_level]
    } else {
      NA_real_
    }

    # Build plot.
    p <- h_next_best_ncrm_loss_plot(
      prob_mat = prob_mat,
      posterior_loss = posterior_loss,
      max_overdose_prob = nextBest@max_overdose_prob,
      dose_grid = data@doseGrid,
      max_eligible_dose_level = sum(is_dose_eligible),
      doselimit = doselimit,
      next_dose = next_dose,
      is_unacceptable_specified = is_unacceptable_specified
    )

    c(list(value = next_dose, probs = probs), p)
  }
)

## NextBestThreePlusThree ----

#' @describeIn nextBest find the next best dose based on the 3+3 method.
#'
#' @aliases nextBest-NextBestThreePlusThree
#'
#' @export
#' @example examples/Rules-method-nextBest-NextBestThreePlusThree.R
#'
setMethod(
  f = "nextBest",
  signature = signature(
    nextBest = "NextBestThreePlusThree",
    doselimit = "missing",
    samples = "missing",
    model = "missing",
    data = "Data"
  ),
  definition = function(nextBest, doselimit, samples, model, data, ...) {
    # The last dose level tested (not necessarily the maximum one).
    last_level <- tail(data@xLevel, 1L)

    # Get number of patients per grid's dose and DLT rate at the last level.
    nPatients <- table(factor(data@x, levels = data@doseGrid))
    n_dlts_last_level <- sum(data@y[data@xLevel == last_level])
    dlt_rate_last_level <- n_dlts_last_level / nPatients[last_level]

    level_change <- if (dlt_rate_last_level < 1 / 3) {
      # Escalate it, unless this is the highest level or the higher dose was already tried.
      ifelse((last_level == data@nGrid) || (nPatients[last_level + 1L] > 0), 0L, 1L)
    } else {
      # Rate is too high, deescalate it, unless an edge case of 1/3, where the decision
      # depends on the num. of patients: if >3, then deescalate it, otherwise stay.
      ifelse((dlt_rate_last_level == 1 / 3) && (nPatients[last_level] <= 3L), 0L, -1L)
    }
    next_dose_level <- last_level + level_change

    # Do we stop here? Only if we have no MTD, or the next level has been tried
    # enough (more than three patients already).
    if (next_dose_level == 0L) {
      next_dose <- NA
      stop_here <- TRUE
    } else {
      next_dose <- data@doseGrid[next_dose_level]
      stop_here <- nPatients[next_dose_level] > 3L
    }

    list(value = next_dose, stopHere = stop_here)
  }
)

## NextBestDualEndpoint ----

#' @describeIn nextBest find the next best dose based on the dual endpoint
#'   model. The additional list element `probs` contains the target and
#'   overdosing probabilities (across all doses in the dose grid) used in the
#'   derivation of the next best dose.
#'
#' @aliases nextBest-NextBestDualEndpoint
#'
#' @export
#' @example examples/Rules-method-nextBest-NextBestDualEndpoint.R
#'
setMethod(
  f = "nextBest",
  signature = signature(
    nextBest = "NextBestDualEndpoint",
    doselimit = "numeric",
    samples = "Samples",
    model = "DualEndpoint",
    data = "Data"
  ),
  definition = function(nextBest, doselimit = Inf, samples, model, data, ...) {
    # Biomarker samples at the dose grid points.
    biom_samples <- samples@data$betaW

    prob_target <- if (nextBest@target_relative) {
      # If 'Emax' parameter available, target biomarker level will be relative to 'Emax',
      # otherwise, it will be relative to the maximum biomarker level achieved
      # in dose range for a given sample.
      if ("Emax" %in% names(samples)) {
        lwr <- nextBest@target[1] * samples@data$Emax
        upr <- nextBest@target[2] * samples@data$Emax
        colMeans(apply(biom_samples, 2L, function(s) (s >= lwr) & (s <= upr)))
      } else {
        target_levels <- apply(biom_samples, 1L, function(x) {
          rng <- range(x)
          min(which(h_in_range(x, nextBest@target * diff(rng) + rng[1] + c(0, 1e-10), bounds_closed = c(FALSE, TRUE))))
        })
        prob_target <- as.vector(table(factor(target_levels, levels = 1:data@nGrid)))
        prob_target / nrow(biom_samples)
      }
    } else {
      colMeans(h_in_range(biom_samples, nextBest@target))
    }

    # Now, compute probabilities to be in overdose tox interval, then flag
    # eligible grid doses after accounting for maximum possible dose and discarding overdoses.
    prob_samples <- sapply(data@doseGrid, prob, model = model, samples = samples)
    prob_overdose <- colMeans(h_in_range(prob_samples, nextBest@overdose, bounds_closed = c(FALSE, TRUE)))

    is_dose_eligible <- h_next_best_eligible_doses(data@doseGrid, doselimit, data@placebo, levels = TRUE) &
      (prob_overdose < nextBest@max_overdose_prob)

    next_dose <- if (any(is_dose_eligible)) {
      # If maximum target probability is higher the threshold, then take that
      # level, otherwise stick to the maximum level that is eligible.
      # next_dose_level is relative to eligible doses.
      next_dose_level <- ifelse(
        test = any(prob_target[is_dose_eligible] > nextBest@target_thresh),
        yes = which.max(prob_target[is_dose_eligible]),
        no = sum(is_dose_eligible)
      )
      data@doseGrid[is_dose_eligible][next_dose_level]
    } else {
      NA_real_
    }

    # Build plots, first for the target probability.
    p1 <- ggplot() +
      geom_bar(
        data = data.frame(Dose = data@doseGrid, y = prob_target * 100),
        aes(x = .data$Dose, y = .data$y),
        stat = "identity",
        position = "identity",
        width = min(diff(data@doseGrid)) / 2,
        colour = "darkgreen",
        fill = "darkgreen"
      ) +
      ylim(c(0, 100)) +
      ylab(paste("Target probability [%]"))

    if (is.finite(doselimit)) {
      p1 <- p1 + geom_vline(xintercept = doselimit, lwd = 1.1, lty = 2, colour = "black")
    }

    if (any(is_dose_eligible)) {
      p1 <- p1 +
        geom_vline(xintercept = data@doseGrid[sum(is_dose_eligible)], lwd = 1.1, lty = 2, colour = "red") +
        geom_point(
          data = data.frame(x = next_dose, y = prob_target[is_dose_eligible][next_dose_level] * 100 + 0.03),
          aes(x = x, y = y),
          size = 3,
          pch = 25,
          col = "red",
          bg = "red"
        )
    }

    # Second, for the overdosing probability.
    p2 <- ggplot() +
      geom_bar(
        data = data.frame(Dose = data@doseGrid, y = prob_overdose * 100),
        aes(x = .data$Dose, y = .data$y),
        stat = "identity",
        position = "identity",
        width = min(diff(data@doseGrid)) / 2,
        colour = "red",
        fill = "red"
      ) +
      geom_hline(yintercept = nextBest@max_overdose_prob * 100, lwd = 1.1, lty = 2, colour = "black") +
      ylim(c(0, 100)) +
      ylab("Overdose probability [%]")

    # Place them below each other.
    plot_joint <- gridExtra::arrangeGrob(p1, p2, nrow = 2)

    list(
      value = next_dose,
      plot = plot_joint,
      singlePlots = list(plot1 = p1, plot2 = p2),
      probs = cbind(dose = data@doseGrid, target = prob_target, overdose = prob_overdose)
    )
  }
)

## NextBestMinDist ----

#' @describeIn nextBest gives the dose which is below the dose limit and has an
#'   estimated DLT probability which is closest to the target dose.
#'
#' @aliases nextBest-NextBestMinDist
#'
#' @export
#'
setMethod(
  f = "nextBest",
  signature = signature(
    nextBest = "NextBestMinDist",
    doselimit = "numeric",
    samples = "Samples",
    model = "GeneralModel",
    data = "Data"
  ),
  definition = function(nextBest, doselimit = Inf, samples, model, data, ...) {
    # Matrix with samples from the dose-tox curve at the dose grid points.
    prob_samples <- sapply(data@doseGrid, prob, model = model, samples = samples, ...)
    dlt_prob <- colMeans(prob_samples)

    # Determine the dose with the closest distance.
    dose_target <- data@doseGrid[which.min(abs(dlt_prob - nextBest@target))]

    # Determine next dose.
    doses_eligible <- h_next_best_eligible_doses(
      data@doseGrid,
      doselimit,
      data@placebo
    )
    next_dose_level_eligible <- which.min(abs(doses_eligible - dose_target))
    next_dose <- doses_eligible[next_dose_level_eligible]

    # Create a plot.
    p <- ggplot(
      data = data.frame(x = data@doseGrid, y = dlt_prob),
      aes(.data$x, .data$y),
      fill = "grey50",
      colour = "grey50"
    ) +
      geom_line() +
      geom_point() +
      coord_cartesian(xlim = range(data@doseGrid)) +
      scale_x_continuous(
        labels = as.character(data@doseGrid),
        breaks = data@doseGrid,
        guide = guide_axis(check.overlap = TRUE)
      ) +
      geom_hline(yintercept = nextBest@target, linetype = "dotted") +
      geom_vline(xintercept = dose_target, colour = "black", lwd = 1.1) +
      geom_text(
        data = data.frame(x = dose_target),
        aes(.data$x, 0),
        label = "Est",
        vjust = -0.5,
        hjust = 0.5,
        colour = "black",
        angle = 90
      ) +
      xlab("Dose") +
      ylab("Posterior toxicity probability")

    if (is.finite(doselimit)) {
      p <- p +
        geom_vline(xintercept = doselimit, colour = "red", lwd = 1.1) +
        geom_text(
          data = data.frame(x = doselimit),
          aes(.data$x, 0),
          label = "Max",
          vjust = -0.5,
          hjust = -0.5,
          colour = "red",
          angle = 90
        )
    }

    p <- p +
      geom_vline(xintercept = next_dose, colour = "blue", lwd = 1.1) +
      geom_text(
        data = data.frame(x = next_dose),
        aes(.data$x, 0),
        label = "Next",
        vjust = -0.5,
        hjust = -1.5,
        colour = "blue",
        angle = 90
      )

    list(
      value = next_dose,
      probs = cbind(dose = data@doseGrid, dlt_prob = dlt_prob),
      plot = p
    )
  }
)

## NextBestInfTheory ----

#' @describeIn nextBest gives the appropriate dose within an information
#'   theoretic framework.
#'
#' @aliases nextBest-NextBestInfTheory
#'
#' @export
#'
setMethod(
  f = "nextBest",
  signature = signature(
    nextBest = "NextBestInfTheory",
    doselimit = "numeric",
    samples = "Samples",
    model = "GeneralModel",
    data = "Data"
  ),
  definition = function(nextBest, doselimit = Inf, samples, model, data, ...) {
    # Matrix with samples from the dose-tox curve at the dose grid points.
    prob_samples <- sapply(data@doseGrid, prob, model = model, samples = samples, ...)

    criterion <- colMeans(h_info_theory_dist(prob_samples, nextBest@target, nextBest@asymmetry))

    is_dose_eligible <- h_next_best_eligible_doses(data@doseGrid, doselimit, data@placebo, levels = TRUE)
    doses_eligible <- data@doseGrid[is_dose_eligible]
    next_best_level <- which.min(criterion[is_dose_eligible])
    next_best <- doses_eligible[next_best_level]
    list(value = next_best)
  }
)

## NextBestTD ----

#' @describeIn nextBest find the next best dose based only on the DLT responses
#'   and for [`LogisticIndepBeta`] model class object without DLT samples.
#'
#' @param model (`ModelTox`)\cr the DLT model.
#' @param in_sim (`flag`)\cr is this method used in simulations? Default as `FALSE`.
#'   If this flag is `TRUE` and target dose estimates (during trial and end-of-trial)
#'   are outside of the dose grid range, the information message is printed by
#'   this method.
#'
#' @aliases nextBest-NextBestTD
#'
#' @export
#' @example examples/Rules-method-nextBest-NextBestTD.R
#'
setMethod(
  f = "nextBest",
  signature = signature(
    nextBest = "NextBestTD",
    doselimit = "numeric",
    samples = "missing",
    model = "LogisticIndepBeta",
    data = "Data"
  ),
  definition = function(nextBest, doselimit = Inf, model, data, in_sim = FALSE, ...) {
    assert_flag(in_sim)

    # 'drt' - during the trial, 'eot' end of trial.
    prob_target_drt <- nextBest@prob_target_drt
    prob_target_eot <- nextBest@prob_target_eot

    # Target dose estimates, i.e. the dose with probability of the occurrence of
    # a DLT that equals to the prob_target_drt or prob_target_eot.
    dose_target_drt <- dose(x = prob_target_drt, model, ...)
    dose_target_eot <- dose(x = prob_target_eot, model, ...)

    # Find the next best doses in the doseGrid. The next best dose is the dose
    # at level closest and below the target dose estimate.
    # h_find_interval assumes that elements in doses_eligible are strictly increasing.
    doses_eligible <- h_next_best_eligible_doses(data@doseGrid, doselimit, data@placebo)

    next_dose_lev_drt <- h_find_interval(dose_target_drt, doses_eligible)
    next_dose_drt <- doses_eligible[next_dose_lev_drt]

    next_dose_lev_eot <- h_find_interval(dose_target_eot, doses_eligible)
    next_dose_eot <- doses_eligible[next_dose_lev_eot]

    # Find the variance of the log of the dose_target_eot.
    mat <- matrix(
      c(
        -1 / (model@phi2),
        -(log(prob_target_eot / (1 - prob_target_eot)) - model@phi1) / (model@phi2)^2
      ),
      nrow = 1
    )
    var_dose_target_eot <- as.vector(mat %*% model@Pcov %*% t(mat))

    # 95% credibility interval.
    ci_dose_target_eot <- exp(log(dose_target_eot) + c(-1, 1) * 1.96 * sqrt(var_dose_target_eot))
    cir_dose_target_eot <- ci_dose_target_eot[2] / ci_dose_target_eot[1]

    # Build plot.
    p <- h_next_best_td_plot(
      prob_target_drt = prob_target_drt,
      dose_target_drt = dose_target_drt,
      prob_target_eot = prob_target_eot,
      dose_target_eot = dose_target_eot,
      data = data,
      prob_dlt = prob(dose = data@doseGrid, model = model, ...),
      doselimit = doselimit,
      next_dose = next_dose_drt
    )

    if (!h_in_range(dose_target_drt, range = dose_grid_range(data), bounds_closed = TRUE) && !in_sim) {
      print(paste("TD", prob_target_drt * 100, "=", dose_target_drt, "not within dose grid"))
    }
    if (!h_in_range(dose_target_eot, range = dose_grid_range(data), bounds_closed = TRUE) && !in_sim) {
      print(paste("TD", prob_target_eot * 100, "=", dose_target_eot, "not within dose grid"))
    }

    list(
      next_dose_drt = next_dose_drt,
      prob_target_drt = prob_target_drt,
      dose_target_drt = dose_target_drt,
      next_dose_eot = next_dose_eot,
      prob_target_eot = prob_target_eot,
      dose_target_eot = dose_target_eot,
      ci_dose_target_eot = ci_dose_target_eot,
      ci_ratio_dose_target_eot = cir_dose_target_eot,
      plot = p
    )
  }
)

## NextBestTDsamples ----

#' @describeIn nextBest find the next best dose based only on the DLT responses
#'   and for [`LogisticIndepBeta`] model class object involving DLT samples.
#'
#' @aliases nextBest-NextBestTDsamples
#'
#' @export
#' @example examples/Rules-method-nextBest-NextBestTDsamples.R
#'
setMethod(
  f = "nextBest",
  signature = signature(
    nextBest = "NextBestTDsamples",
    doselimit = "numeric",
    samples = "Samples",
    model = "LogisticIndepBeta",
    data = "Data"
  ),
  definition = function(nextBest, doselimit = Inf, samples, model, data, in_sim, ...) {
    # Generate target dose samples, i.e. the doses with probability of the
    # occurrence of a DLT that equals to the nextBest@prob_target_drt
    # (or nextBest@prob_target_eot, respectively).
    dose_target_drt_samples <- dose(x = nextBest@prob_target_drt, model, samples, ...)
    dose_target_eot_samples <- dose(x = nextBest@prob_target_eot, model, samples, ...)

    # Derive the prior/posterior estimates based on two above samples.
    dose_target_drt <- nextBest@derive(dose_target_drt_samples)
    dose_target_eot <- nextBest@derive(dose_target_eot_samples)

    # Find the next doses in the doseGrid. The next dose is the dose at level
    # closest and below the dose_target_drt (or dose_target_eot, respectively).
    # h_find_interval assumes that elements in doses_eligible are strictly increasing.
    doses_eligible <- h_next_best_eligible_doses(data@doseGrid, doselimit, data@placebo)

    next_dose_lev_drt <- h_find_interval(dose_target_drt, doses_eligible)
    next_dose_drt <- doses_eligible[next_dose_lev_drt]

    next_dose_lev_eot <- h_find_interval(dose_target_eot, doses_eligible)
    next_dose_eot <- doses_eligible[next_dose_lev_eot]

    # 95% credibility interval.
    ci_dose_target_eot <- as.numeric(quantile(dose_target_eot_samples, probs = c(0.025, 0.975)))
    cir_dose_target_eot <- ci_dose_target_eot[2] / ci_dose_target_eot[1]

    # Build plot.
    p <- h_next_best_tdsamples_plot(
      dose_target_drt_samples = dose_target_drt_samples,
      dose_target_eot_samples = dose_target_eot_samples,
      dose_target_drt = dose_target_drt,
      dose_target_eot = dose_target_eot,
      dose_grid_range = range(data@doseGrid),
      nextBest = nextBest,
      doselimit = doselimit,
      next_dose = next_dose_drt
    )

    list(
      next_dose_drt = next_dose_drt,
      prob_target_drt = nextBest@prob_target_drt,
      dose_target_drt = dose_target_drt,
      next_dose_eot = next_dose_eot,
      prob_target_eot = nextBest@prob_target_eot,
      dose_target_eot = dose_target_eot,
      ci_dose_target_eot = ci_dose_target_eot,
      ci_ratio_dose_target_eot = cir_dose_target_eot,
      plot = p
    )
  }
)

## NextBestMaxGain ----

#' @describeIn nextBest find the next best dose based only on pseudo DLT model
#'   [`ModelTox`] and [`Effloglog`] efficacy model without samples.
#'
#' @param model (`ModelTox`)\cr the DLT model.
#' @param model_eff (`Effloglog`)\cr the efficacy model.
#' @param in_sim (`flag`)\cr is this method used in simulations? Default as `FALSE`.
#'   If this flag is `TRUE` and target dose estimates (during trial and end-of-trial)
#'   are outside of the dose grid range, the information message is printed by
#'   this method.
#'
#' @aliases nextBest-NextBestMaxGain
#'
#' @export
#' @example examples/Rules-method-nextBest-NextBestMaxGain.R
#'
setMethod(
  f = "nextBest",
  signature = signature(
    nextBest = "NextBestMaxGain",
    doselimit = "numeric",
    samples = "missing",
    model = "ModelTox",
    data = "DataDual"
  ),
  definition = function(nextBest, doselimit = Inf, model, data, model_eff, in_sim = FALSE, ...) {
    assert_class(model_eff, "Effloglog")
    assert_flag(in_sim)

    # 'drt' - during the trial, 'eot' end of trial.
    prob_target_drt <- nextBest@prob_target_drt
    prob_target_eot <- nextBest@prob_target_eot

    # Target dose estimates, i.e. the dose with probability of the occurrence of
    # a DLT that equals to the prob_target_drt or prob_target_eot.
    dose_target_drt <- dose(x = prob_target_drt, model, ...)
    dose_target_eot <- dose(x = prob_target_eot, model, ...)

    # Find the dose which gives the maximum gain.
    dosegrid_range <- dose_grid_range(data)
    opt <- optim(
      par = dosegrid_range[1],
      fn = function(DOSE) {
        -gain(DOSE, model_dle = model, model_eff = model_eff, ...)
      },
      method = "L-BFGS-B",
      lower = dosegrid_range[1],
      upper = dosegrid_range[2]
    )
    dose_mg <- opt$par # this is G*. # no lintr
    max_gain <- -opt$value

    # Print info message if dose target is outside of the range.
    if (!h_in_range(dose_target_drt, range = dose_grid_range(data), bounds_closed = FALSE) && !in_sim) {
      print(paste("Estimated TD", prob_target_drt * 100, "=", dose_target_drt, "not within dose grid"))
    }
    if (!h_in_range(dose_target_eot, range = dose_grid_range(data), bounds_closed = FALSE) && !in_sim) {
      print(paste("Estimated TD", prob_target_eot * 100, "=", dose_target_eot, "not within dose grid"))
    }
    if (!h_in_range(dose_mg, range = dose_grid_range(data), bounds_closed = FALSE) && !in_sim) {
      print(paste("Estimated max gain dose =", dose_mg, "not within dose grid"))
    }

    # Get closest grid doses for a given target doses.
    nb_doses_at_grid <- h_next_best_mg_doses_at_grid(
      dose_target_drt = dose_target_drt,
      dose_target_eot = dose_target_eot,
      dose_mg = dose_mg,
      dose_grid = data@doseGrid,
      doselimit = doselimit,
      placebo = data@placebo
    )

    # 95% credibility intervals and corresponding ratios for maximum gain dose and target dose eot.
    ci <- h_next_best_mg_ci(
      dose_target = dose_target_eot,
      dose_mg = dose_mg,
      prob_target = prob_target_eot,
      placebo = data@placebo,
      model = model,
      model_eff = model_eff
    )

    # Build plot.
    p <- h_next_best_mg_plot(
      prob_target_drt = prob_target_drt,
      dose_target_drt = dose_target_drt,
      prob_target_eot = prob_target_eot,
      dose_target_eot = dose_target_eot,
      dose_mg = dose_mg,
      max_gain = max_gain,
      next_dose = nb_doses_at_grid$next_dose,
      doselimit = doselimit,
      data = data,
      model = model,
      model_eff = model_eff
    )

    list(
      next_dose = nb_doses_at_grid$next_dose,
      prob_target_drt = prob_target_drt,
      dose_target_drt = dose_target_drt,
      next_dose_drt = nb_doses_at_grid$next_dose_drt,
      prob_target_eot = prob_target_eot,
      dose_target_eot = dose_target_eot,
      next_dose_eot = nb_doses_at_grid$next_dose_eot,
      dose_max_gain = dose_mg,
      next_dose_max_gain = nb_doses_at_grid$next_dose_mg,
      ci_dose_target_eot = ci$ci_dose_target,
      ci_ratio_dose_target_eot = ci$ci_ratio_dose_target,
      ci_dose_max_gain = ci$ci_dose_mg,
      ci_ratio_dose_max_gain = ci$ci_ratio_dose_mg,
      plot = p
    )
  }
)

## NextBestMaxGainSamples ----

#' @describeIn nextBest find the next best dose based on DLT and efficacy
#'   responses with DLT and efficacy samples.
#'
#' @param model (`ModelTox`)\cr the DLT model.
#' @param model_eff (`Effloglog` or `EffFlexi`)\cr the efficacy model.
#' @param samples_eff (`Samples`)\cr posterior samples from `model_eff` parameters
#'   given `data`.
#' @param in_sim (`flag`)\cr is this method used in simulations? Default as `FALSE`.
#'   If this flag is `TRUE` and target dose estimates (during trial and end-of-trial)
#'   are outside of the dose grid range, the information message is printed by
#'   this method.
#'
#' @aliases nextBest-NextBestMaxGainSamples
#'
#' @export
#' @example examples/Rules-method-nextBest-NextBestMaxGainSamples.R
#'
setMethod(
  f = "nextBest",
  signature = signature(
    nextBest = "NextBestMaxGainSamples",
    doselimit = "numeric",
    samples = "Samples",
    model = "ModelTox",
    data = "DataDual"
  ),
  definition = function(nextBest, doselimit = Inf, samples, model, data, model_eff, samples_eff, in_sim = FALSE, ...) {
    assert_true(test_class(model_eff, "Effloglog") || test_class(model_eff, "EffFlexi"))
    assert_class(samples_eff, "Samples")
    assert_flag(in_sim)

    # 'drt' - during the trial, 'eot' end of trial.
    prob_target_drt <- nextBest@prob_target_drt
    prob_target_eot <- nextBest@prob_target_eot

    # Generate target dose samples, i.e. the doses with probability of the
    # occurrence of a DLT that equals to the prob_target_drt or prob_target_eot.
    dose_target_drt_samples <- dose(x = prob_target_drt, model, samples = samples, ...)
    dose_target_eot_samples <- dose(x = prob_target_eot, model, samples = samples, ...)

    # Derive the prior/posterior estimates based on two above samples.
    dose_target_drt <- nextBest@derive(dose_target_drt_samples)
    dose_target_eot <- nextBest@derive(dose_target_eot_samples)

    # Gain samples.
    gain_samples <- sapply(data@doseGrid, gain, model, samples, model_eff, samples_eff, ...)
    # For every sample, get the dose (from the dose grid) that gives the maximum gain value.
    dose_lev_mg_samples <- apply(gain_samples, 1, which.max)
    dose_mg_samples <- data@doseGrid[dose_lev_mg_samples]
    # Maximum gain dose estimate is the nth percentile of the maximum gain dose samples.
    dose_mg <- nextBest@mg_derive(dose_mg_samples)
    gain_values <- apply(gain_samples, 2, FUN = nextBest@mg_derive)

    # Print info message if dose target is outside of the range.
    dosegrid_range <- dose_grid_range(data)
    if (!h_in_range(dose_target_drt, range = dosegrid_range, bounds_closed = FALSE) && !in_sim) {
      print(paste("Estimated TD", prob_target_drt * 100, "=", dose_target_drt, "not within dose grid"))
    }
    if (!h_in_range(dose_target_eot, range = dosegrid_range, bounds_closed = FALSE) && !in_sim) {
      print(paste("Estimated TD", prob_target_eot * 100, "=", dose_target_eot, "not within dose grid"))
    }
    if (!h_in_range(dose_mg, range = dosegrid_range, bounds_closed = FALSE) && !in_sim) {
      print(paste("Estimated max gain dose =", dose_mg, "not within dose grid"))
    }

    # Get closest grid doses for a given target doses.
    nb_doses_at_grid <- h_next_best_mg_doses_at_grid(
      dose_target_drt = dose_target_drt,
      dose_target_eot = dose_target_eot,
      dose_mg = dose_mg,
      dose_grid = data@doseGrid,
      doselimit = doselimit,
      placebo = data@placebo
    )

    # 95% credibility intervals and corresponding ratios for maximum gain dose and target dose eot.
    ci_dose_mg <- as.numeric(quantile(dose_mg_samples, probs = c(0.025, 0.975)))
    cir_dose_mg <- ci_dose_mg[2] / ci_dose_mg[1]

    ci_dose_target_eot <- as.numeric(quantile(dose_target_eot, probs = c(0.025, 0.975)))
    cir_dose_target_eot <- ci_dose_target_eot[2] / ci_dose_target_eot[1]

    # Build plot.
    p <- h_next_best_mgsamples_plot(
      prob_target_drt = prob_target_drt,
      dose_target_drt = dose_target_drt,
      prob_target_eot = prob_target_eot,
      dose_target_eot = dose_target_eot,
      dose_mg = dose_mg,
      dose_mg_samples = dose_mg_samples,
      next_dose = nb_doses_at_grid$next_dose,
      doselimit = doselimit,
      dose_grid_range = dosegrid_range
    )

    list(
      next_dose = nb_doses_at_grid$next_dose,
      prob_target_drt = prob_target_drt,
      dose_target_drt = dose_target_drt,
      next_dose_drt = nb_doses_at_grid$next_dose_drt,
      prob_target_eot = prob_target_eot,
      dose_target_eot = dose_target_eot,
      next_dose_eot = nb_doses_at_grid$next_dose_eot,
      dose_max_gain = dose_mg,
      next_dose_max_gain = nb_doses_at_grid$next_dose_mg,
      ci_dose_target_eot = ci_dose_target_eot,
      ci_ratio_dose_target_eot = cir_dose_target_eot,
      ci_dose_max_gain = ci_dose_mg,
      ci_ratio_dose_max_gain = cir_dose_mg,
      plot = p
    )
  }
)

## NextBestProbMTDLTE ----

#' @describeIn nextBest find the next best dose based with the highest
#'  probability of having a toxicity rate less or equal to the target toxicity
#'  level.
#'
#' @aliases nextBest-NextBestProbMTDLTE
#'
#' @export
#' @example examples/Rules-method-nextBest-NextBestProbMTDLTE.R
#'
setMethod(
  f = "nextBest",
  signature = signature(
    nextBest = "NextBestProbMTDLTE",
    doselimit = "numeric",
    samples = "Samples",
    model = "GeneralModel",
    data = "Data"
  ),
  definition = function(nextBest, doselimit, samples, model, data, ...) {
    # Matrix with samples from the dose-tox curve at the dose grid points.
    prob_samples <- sapply(data@doseGrid, prob, model = model, samples = samples, ...)

    # Determine the maximum dose level with a toxicity probability below or
    # equal to the target and calculate how often a dose is selected as MTD
    # across iterations.
    # The first element of the vector is the relative frequency that no
    # dose in the grid is below or equal to the target, the
    # second element that the 1st dose of the grid is the MTD, etc..
    prob_mtd_lte <- prop.table(
      table(factor(
        rowSums(prob_samples <= nextBest@target),
        levels = 0:data@nGrid
      ))
    )

    allocation_crit <- as.vector(prob_mtd_lte)
    names(allocation_crit) <- as.character(c(0, data@doseGrid))

    # In case that placebo is used, placebo and the portion that is not assigned
    # to any dose of the grid are merged.
    if (data@placebo) {
      allocation_crit[1] <- sum(allocation_crit[1:2])
      allocation_crit <- allocation_crit[-2]
    }

    # Handling of the portion that is not assigned to an active dose of
    # the dose grid. The portion is added to the minimum active dose
    # of the dose grid.
    allocation_crit[2] <- sum(allocation_crit[1:2])
    allocation_crit <- allocation_crit[-1]

    # Determine the dose with the highest relative frequency.
    allocation_crit_dose <- as.numeric(names(allocation_crit))
    dose_target <- allocation_crit_dose[which.max(allocation_crit)]

    # Determine next dose.
    doses_eligible <- h_next_best_eligible_doses(
      data@doseGrid,
      doselimit,
      data@placebo
    )
    next_dose_level_eligible <- which.min(abs(doses_eligible - dose_target))
    next_dose <- doses_eligible[next_dose_level_eligible]

    # Create a plot.
    plt_data <- if (data@placebo && (data@doseGrid[1] == next_dose)) {
      data.frame(
        x = as.factor(data@doseGrid),
        y = c(0, as.numeric(allocation_crit)) * 100
      )
    } else {
      data.frame(
        x = as.factor(allocation_crit_dose),
        y = as.numeric(allocation_crit) * 100
      )
    }

    p <- ggplot(
      data = plt_data,
      fill = "grey50",
      colour = "grey50"
    ) +
      geom_col(aes(x, y), fill = "grey75") +
      scale_x_discrete(drop = FALSE, guide = guide_axis(check.overlap = TRUE)) +
      geom_vline(
        xintercept = as.factor(dose_target),
        lwd = 1.1,
        colour = "black"
      ) +
      geom_text(
        data = data.frame(x = as.factor(dose_target)),
        aes(.data$x, 0),
        label = "Est",
        vjust = -0.5,
        hjust = -0.5,
        colour = "black",
        angle = 90
      ) +
      xlab("Dose") +
      ylab(paste("Allocation criterion [%]"))

    if (is.finite(doselimit)) {
      doselimit_level <- if (sum(allocation_crit_dose == doselimit) > 0) {
        which(allocation_crit_dose == doselimit)
      } else {
        ifelse(test = data@placebo && (data@doseGrid[1] == next_dose),
          yes = 1.5,
          no = sum(allocation_crit_dose < doselimit) + 0.5
        )
      }

      p <- p +
        geom_vline(
          xintercept = doselimit_level,
          colour = "red", lwd = 1.1
        ) +
        geom_text(
          data = data.frame(x = doselimit_level),
          aes(.data$x, 0),
          label = "Max",
          vjust = -0.5,
          hjust = -1.5,
          colour = "red",
          angle = 90
        )
    }

    p <- p +
      geom_vline(
        xintercept = as.factor(next_dose),
        colour = "blue", lwd = 1.1
      ) +
      geom_text(
        data = data.frame(x = as.factor(next_dose)),
        aes(.data$x, 0),
        label = "Next",
        vjust = -0.5,
        hjust = -2.5,
        colour = "blue",
        angle = 90
      )

    list(
      value = next_dose,
      allocation = cbind(dose = allocation_crit_dose, allocation = allocation_crit),
      plot = p
    )
  }
)

## NextBestProbMTDMinDist ----

#' @describeIn nextBest find the next best dose based with the highest
#'  probability of having a toxicity rate with minimum distance to the
#'  target toxicity level.
#'
#' @aliases nextBest-NextBestProbMTDMinDist
#'
#' @export
#' @example examples/Rules-method-nextBest-NextBestProbMtdMinDist.R
#'
setMethod(
  f = "nextBest",
  signature = signature(
    nextBest = "NextBestProbMTDMinDist",
    doselimit = "numeric",
    samples = "Samples",
    model = "GeneralModel",
    data = "Data"
  ),
  definition = function(nextBest, doselimit, samples, model, data, ...) {
    # Matrix with samples from the dose-tox curve at the dose grid points.
    prob_samples <- sapply(data@doseGrid, prob, model = model, samples = samples, ...)

    # Determine which dose level has the minimum distance to target.
    dose_min_mtd_dist <- apply(
      prob_samples, 1, function(x) which.min(abs(x - nextBest@target))
    )

    allocation_crit <- prop.table(
      table(factor(dose_min_mtd_dist, levels = 1:data@nGrid))
    )
    names(allocation_crit) <- as.character(data@doseGrid)

    # In case that placebo is used, placebo and the first non-placebo dose
    # of the grid are merged.
    if (data@placebo) {
      allocation_crit[2] <- sum(allocation_crit[1:2])
      allocation_crit <- allocation_crit[-1]
    }

    # Determine the dose with the highest relative frequency.
    allocation_crit_dose <- as.numeric(names(allocation_crit))
    dose_target <- allocation_crit_dose[which.max(allocation_crit)]

    # Determine next dose.
    doses_eligible <- h_next_best_eligible_doses(
      data@doseGrid,
      doselimit,
      data@placebo
    )
    next_dose_level_eligible <- which.min(abs(doses_eligible - dose_target))
    next_dose <- doses_eligible[next_dose_level_eligible]

    # Create a plot.
    plt_data <- if (data@placebo && data@doseGrid[1] == next_dose) {
      data.frame(
        x = as.factor(data@doseGrid),
        y = c(0, as.numeric(allocation_crit)) * 100
      )
    } else {
      data.frame(
        x = as.factor(allocation_crit_dose),
        y = as.numeric(allocation_crit) * 100
      )
    }

    p <- ggplot(
      data = plt_data,
      fill = "grey50",
      colour = "grey50"
    ) +
      geom_col(aes(x, y), fill = "grey75") +
      scale_x_discrete(guide = guide_axis(check.overlap = TRUE)) +
      geom_vline(
        xintercept = as.factor(dose_target),
        lwd = 1.1,
        colour = "black"
      ) +
      geom_text(
        data = data.frame(x = as.factor(dose_target)),
        aes(.data$x, 0),
        label = "Est",
        vjust = -0.5,
        hjust = -0.5,
        colour = "black",
        angle = 90
      ) +
      xlab("Dose") +
      ylab(paste("Allocation criterion [%]"))


    if (is.finite(doselimit)) {
      doselimit_level <- if (any(allocation_crit_dose == doselimit)) {
        which(allocation_crit_dose == doselimit)
      } else {
        ifelse(test = data@placebo && data@doseGrid[1] == next_dose,
          yes = 1.5,
          no = sum(allocation_crit_dose < doselimit) + 0.5
        )
      }

      p <- p +
        geom_vline(
          xintercept = doselimit_level,
          colour = "red", lwd = 1.1
        ) +
        geom_text(
          data = data.frame(x = doselimit_level),
          aes(.data$x, 0),
          label = "Max",
          vjust = -0.5,
          hjust = -1.5,
          colour = "red",
          angle = 90
        )
    }

    p <- p +
      geom_vline(
        xintercept = as.factor(next_dose),
        colour = "blue", lwd = 1.1
      ) +
      geom_text(
        data = data.frame(x = as.factor(next_dose)),
        aes(.data$x, 0),
        label = "Next",
        vjust = -0.5,
        hjust = -2.5,
        colour = "blue",
        angle = 90
      )

    list(
      value = next_dose,
      allocation = cbind(dose = allocation_crit_dose, allocation = allocation_crit),
      plot = p
    )
  }
)

## NextBestOrdinal ----

#' @describeIn nextBest find the next best dose for ordinal CRM models.
#'
#' @aliases nextBest-NextBestOrdinal
#'
#' @export
#' @example examples/Rules-method-nextBest-NextBestOrdinal.R
#'
setMethod(
  f = "nextBest",
  signature = signature(
    nextBest = "NextBestOrdinal",
    doselimit = "numeric",
    samples = "Samples",
    model = "GeneralModel",
    data = "Data"
  ),
  definition = function(nextBest, doselimit = Inf, samples, model, data, ...) {
    stop(
      paste0(
        "NextBestOrdinal objects can only be used with LogisticLogNormalOrdinal ",
        "models and DataOrdinal data objects. In this case, the model is a '",
        class(model),
        "' object and the data is in a ",
        class(data),
        " object."
      )
    )
  }
)

#' @describeIn nextBest find the next best dose for ordinal CRM models.
#'
#' @aliases nextBest-NextBestOrdinal
#'
#' @export
#' @example examples/Rules-method-nextBest-NextBestOrdinal.R
#'
setMethod(
  f = "nextBest",
  signature = signature(
    nextBest = "NextBestOrdinal",
    doselimit = "numeric",
    samples = "Samples",
    model = "LogisticLogNormalOrdinal",
    data = "DataOrdinal"
  ),
  definition = function(nextBest, doselimit = Inf, samples, model, data, ...) {
    nextBest(
      nextBest = nextBest@rule,
      doselimit = doselimit,
      samples = h_convert_ordinal_samples(samples, nextBest@grade),
      model = h_convert_ordinal_model(model, nextBest@grade),
      data = h_convert_ordinal_data(data, nextBest@grade),
      ...
    )
  }
)

# maxDose ----

## generic ----

#' Determine the Maximum Possible Next Dose
#'
#' @description `r lifecycle::badge("stable")`
#'
#' This function determines the upper limit of the next dose based on the
#' `increments`and the `data`.
#'
#' @param increments (`Increments`)\cr the rule for the next best dose.
#' @param data (`Data`)\cr input data.
#' @param ... additional arguments without method dispatch.
#'
#' @return A `number`, the maximum possible next dose.
#'
#' @export
#'
setGeneric(
  name = "maxDose",
  def = function(increments, data, ...) {
    standardGeneric("maxDose")
  },
  valueClass = "numeric"
)

## IncrementsRelative ----

#' @describeIn maxDose determine the maximum possible next dose based on
#'   relative increments.
#'
#' @aliases maxDose-IncrementsRelative
#'
#' @export
#' @example examples/Rules-method-maxDose-IncrementsRelative.R
#'
setMethod(
  f = "maxDose",
  signature = signature(
    increments = "IncrementsRelative",
    data = "Data"
  ),
  definition = function(increments, data, ...) {
    last_dose <- data@x[data@nObs]
    # Determine in which interval the `last_dose` is.
    assert_true(last_dose >= head(increments@intervals, 1))
    last_dose_interval <- findInterval(x = last_dose, vec = increments@intervals)
    (1 + increments@increments[last_dose_interval]) * last_dose
  }
)

## IncrementsRelativeDLT ----

#' @describeIn maxDose determine the maximum possible next dose based on
#'   relative increments determined by DLTs so far.
#'
#' @aliases maxDose-IncrementsRelativeDLT
#'
#' @export
#' @example examples/Rules-method-maxDose-IncrementsRelativeDLT.R
#'
setMethod(
  f = "maxDose",
  signature = signature(
    increments = "IncrementsRelativeDLT",
    data = "Data"
  ),
  definition = function(increments, data, ...) {
    dlt_count <- sum(data@y)
    # Determine in which interval the `dlt_count` is.
    assert_true(dlt_count >= increments@intervals[1])
    dlt_count_interval <- findInterval(x = dlt_count, vec = increments@intervals)
    (1 + increments@increments[dlt_count_interval]) * data@x[data@nObs]
  }
)

## IncrementsRelativeDLTCurrent ----

#' @describeIn maxDose determine the maximum possible next dose based on
#'   relative increments determined by DLTs in the current cohort.
#'
#' @aliases maxDose-IncrementsRelativeDLTCurrent
#'
#' @export
#' @example examples/Rules-method-maxDose-IncrementsRelativeDLTCurrent.R
#'
setMethod(
  f = "maxDose",
  signature = signature(
    increments = "IncrementsRelativeDLTCurrent",
    data = "Data"
  ),
  definition = function(increments, data, ...) {
    last_dose <- data@x[data@nObs]

    # Determine how many DLTs have occurred in the last cohort.
    last_cohort <- data@cohort[data@nObs]
    last_cohort_indices <- which(data@cohort == last_cohort)
    dlt_count_lcohort <- sum(data@y[last_cohort_indices])

    # Determine in which interval the `dlt_count_lcohort` is.
    assert_true(dlt_count_lcohort >= increments@intervals[1])
    dlt_count_lcohort_int <- findInterval(x = dlt_count_lcohort, vec = increments@intervals)
    (1 + increments@increments[dlt_count_lcohort_int]) * last_dose
  }
)

## IncrementsRelativeParts ----

#' @describeIn maxDose determine the maximum possible next dose based on
#'   relative increments as well as part 1 and beginning of part 2.
#'
#' @aliases maxDose-IncrementsRelativeParts
#'
#' @export
#' @example examples/Rules-method-maxDose-IncrementsRelativeParts.R
#'
setMethod(
  f = "maxDose",
  signature = signature(
    increments = "IncrementsRelativeParts",
    data = "DataParts"
  ),
  definition = function(increments, data, ...) {
    all_in_part1 <- all(data@part == 1L)
    incrmnt <- if (all_in_part1) {
      part2_started <- data@nextPart == 2L
      if (part2_started) {
        any_dlt <- any(data@y == 1L)
        if (any_dlt) {
          increments@dlt_start
        } else if (increments@clean_start <= 0L) {
          increments@clean_start
        }
      } else {
        1L
      }
    }

    if (is.null(incrmnt)) {
      callNextMethod(increments, data, ...)
    } else {
      max_dose_lev_part1 <- match_within_tolerance(max(data@x), data@part1Ladder)
      new_max_dose_level <- max_dose_lev_part1 + incrmnt
      assert_true(new_max_dose_level >= 0L)
      assert_true(new_max_dose_level <= length(data@part1Ladder))
      data@part1Ladder[new_max_dose_level]
    }
  }
)

## IncrementsDoseLevels ----

#' @describeIn maxDose determine the maximum possible next dose based on
#'   the number of dose grid levels. That is, the max dose is determined as
#'   the one which level is equal to: base dose level + level increment.
#'   The base dose level is the level of the last dose in grid or the level
#'   of the maximum dose applied, which is defined in `increments` object.
#'   Find out more in [`IncrementsDoseLevels`].
#'
#' @aliases maxDose-IncrementsDoseLevels
#'
#' @export
#' @example examples/Rules-method-maxDose-IncrementsDoseLevels.R
#'
setMethod(
  f = "maxDose",
  signature = signature(
    increments = "IncrementsDoseLevels",
    data = "Data"
  ),
  definition = function(increments, data, ...) {
    # Determine what is the basis level for increment,
    # i.e. the last dose or the max dose applied.
    basis_dose_level <- ifelse(
      increments@basis_level == "last", data@xLevel[data@nObs], max(data@xLevel)
    )
    max_dose_level <- min(basis_dose_level + increments@levels, data@nGrid)
    data@doseGrid[max_dose_level]
  }
)

## IncrementsHSRBeta ----

#' @describeIn maxDose determine the maximum possible next dose for escalation.
#'
#' @aliases maxDose-IncrementsHSRBeta
#'
#' @export
#' @example examples/Rules-method-maxDose-IncrementsHSRBeta.R
#'
setMethod(
  f = "maxDose",
  signature = signature(
    increments = "IncrementsHSRBeta",
    data = "Data"
  ),
  definition = function(increments, data, ...) {
    # Summary of observed data per dose level.
    y <- factor(data@y, levels = c("0", "1"))
    dlt_tab <- table(y, data@x)

    # Ignore placebo if applied.
    if (data@placebo == TRUE & min(data@x) == data@doseGrid[1]) {
      dlt_tab <- dlt_tab[, -1]
    }

    # Extract dose names as these get lost if only one dose available.
    non_plcb_doses <- unique(sort(as.numeric(colnames(dlt_tab))))

    # Toxicity probability per dose level.
    x <- dlt_tab[2, ]
    n <- apply(dlt_tab, 2, sum)
    tox_prob <- pbeta(
      increments@target,
      x + increments@a,
      n - x + increments@b,
      lower.tail = FALSE
    )

    # Return the min toxic dose level or maximum dose level if no dose is toxic,
    # while ignoring placebo.
    dose_tox <- if (sum(tox_prob > increments@prob) > 0) {
      min(non_plcb_doses[which(tox_prob > increments@prob)])
    } else {
      # Add small value to max dose, so that the max dose is always smaller.
      max(data@doseGrid) + 0.01
    }

    # Determine the next maximum possible dose.
    # In case that the first active dose is above probability threshold,
    # the first active dose is reported as maximum. I.e. in case that placebo is used,
    # the second dose is reported. Please note that this rule should be used together
    # with the hard safety stopping rule to avoid inconsistent results.
    max(data@doseGrid[data@doseGrid < dose_tox], data@doseGrid[data@placebo + 1])
  }
)

## IncrementsMin ----

#' @describeIn maxDose determine the maximum possible next dose based on
#'   multiple increment rules, taking the minimum across individual increments.
#'
#' @aliases maxDose-IncrementsMin
#'
#' @export
#' @example examples/Rules-method-maxDose-IncrementsMin.R
#'
setMethod(
  f = "maxDose",
  signature = signature(
    increments = "IncrementsMin",
    data = "Data"
  ),
  definition = function(increments, data, ...) {
    individual_results <- sapply(increments@increments_list, maxDose, data = data, ...)
    min(individual_results)
  }
)

#' @describeIn maxDose determine the maximum possible next dose based on
#'   multiple increment rules, taking the minimum across individual increments.
#'
#' @aliases maxDose-IncrementsMin
#'
#' @export
setMethod(
  f = "maxDose",
  signature = signature(
    increments = "IncrementsMin",
    data = "DataOrdinal"
  ),
  definition = function(increments, data, ...) {
    individual_results <- sapply(increments@increments_list, maxDose, data = data, ...)
    min(individual_results)
  }
)

## IncrementsOrdinal ----

#' @describeIn maxDose determine the maximum possible next dose in an ordinal
#' CRM trial
#'
#' @aliases maxDose-IncrementsOrdinal
#'
#' @export
#' @example examples/Rules-method-maxDose-IncrementsOrdinal.R
#'
setMethod(
  f = "maxDose",
  signature = signature(
    increments = "IncrementsOrdinal",
    data = "DataOrdinal"
  ),
  definition = function(increments, data, ...) {
    maxDose(
      increments = increments@rule,
      data = h_convert_ordinal_data(
        data,
        increments@grade,
        ...
      )
    )
  }
)

# nolint start

## ============================================================

## --------------------------------------------------
## "AND" combination of stopping rules
## --------------------------------------------------

##' The method combining two atomic stopping rules
##'
##' @param e1 First \code{\linkS4class{Stopping}} object
##' @param e2 Second \code{\linkS4class{Stopping}} object
##' @return The \code{\linkS4class{StoppingAll}} object
##'
##' @example examples/Rules-method-and-stopping-stopping.R
##' @keywords methods
setMethod("&",
  signature(
    e1 = "Stopping",
    e2 = "Stopping"
  ),
  def =
    function(e1, e2) {
      StoppingAll(list(e1, e2))
    }
)

##' The method combining a stopping list and an atomic
##'
##' @param e1 \code{\linkS4class{StoppingAll}} object
##' @param e2 \code{\linkS4class{Stopping}} object
##' @return The modified \code{\linkS4class{StoppingAll}} object
##'
##' @example examples/Rules-method-and-stoppingAll-stopping.R
##' @keywords methods
setMethod("&",
  signature(
    e1 = "StoppingAll",
    e2 = "Stopping"
  ),
  def =
    function(e1, e2) {
      e1@stop_list <- c(
        e1@stop_list,
        e2
      )
      return(e1)
    }
)

##' The method combining an atomic and a stopping list
##'
##' @param e1 \code{\linkS4class{Stopping}} object
##' @param e2 \code{\linkS4class{StoppingAll}} object
##' @return The modified \code{\linkS4class{StoppingAll}} object
##'
##' @example examples/Rules-method-and-stopping-stoppingAll.R
##' @keywords methods
setMethod("&",
  signature(
    e1 = "Stopping",
    e2 = "StoppingAll"
  ),
  def =
    function(e1, e2) {
      e2@stop_list <- c(
        e1,
        e2@stop_list
      )
      return(e2)
    }
)

## --------------------------------------------------
## "OR" combination of stopping rules
## --------------------------------------------------

##' The method combining two atomic stopping rules
##'
##' @param e1 First \code{\linkS4class{Stopping}} object
##' @param e2 Second \code{\linkS4class{Stopping}} object
##' @return The \code{\linkS4class{StoppingAny}} object
##'
##' @aliases |,Stopping,Stopping-method
##' @name or-Stopping-Stopping
##' @example examples/Rules-method-or-stopping-stopping.R
##' @keywords methods
setMethod("|",
  signature(
    e1 = "Stopping",
    e2 = "Stopping"
  ),
  def =
    function(e1, e2) {
      StoppingAny(list(e1, e2))
    }
)

##' The method combining a stopping list and an atomic
##'
##' @param e1 \code{\linkS4class{StoppingAny}} object
##' @param e2 \code{\linkS4class{Stopping}} object
##' @return The modified \code{\linkS4class{StoppingAny}} object
##'
##' @aliases |,StoppingAny,Stopping-method
##' @name or-Stopping-StoppingAny
##' @example examples/Rules-method-or-stoppingAny-stopping.R
##' @keywords methods
setMethod("|",
  signature(
    e1 = "StoppingAny",
    e2 = "Stopping"
  ),
  def =
    function(e1, e2) {
      e1@stop_list <- c(
        e1@stop_list,
        e2
      )
      return(e1)
    }
)

##' The method combining an atomic and a stopping list
##'
##' @param e1 \code{\linkS4class{Stopping}} object
##' @param e2 \code{\linkS4class{StoppingAny}} object
##' @return The modified \code{\linkS4class{StoppingAny}} object
##'
##' @aliases |,Stopping,StoppingAny-method
##' @name or-StoppingAny-Stopping
##' @example examples/Rules-method-or-stopping-stoppingAny.R
##' @keywords methods
setMethod("|",
  signature(
    e1 = "Stopping",
    e2 = "StoppingAny"
  ),
  def =
    function(e1, e2) {
      e2@stop_list <- c(
        e1,
        e2@stop_list
      )
      return(e2)
    }
)

# nolint end

# Stopping ----

## generic ----

#' Stop the trial?
#'
#' @description `r lifecycle::badge("stable")`
#'
#' This function returns whether to stop the trial.
#'
#' @param stopping (`Stopping`)\cr the rule for stopping the trial.
#' @param dose the recommended next best dose.
#' @param samples (`Samples`)\cr the mcmc samples.
#' @param model (`GeneralModel`)\cr the model.
#' @param data (`Data`)\cr input data.
#' @param ... additional arguments without method dispatch.
#'
#' @return logical value: `TRUE` if the trial can be stopped, `FALSE`
#' otherwise. It should have an attribute `message` which gives the reason
#' for the decision.
#'
#' @export
#' @example examples/Rules-method-CombiningStoppingRulesAndOr.R
setGeneric(
  name = "stopTrial",
  def = function(stopping, dose, samples, model, data, ...) {
    standardGeneric("stopTrial")
  },
  valueClass = "logical"
)

## StoppingMissingDose ----

#' @describeIn stopTrial Stop based on value returned by next best dose.
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' @aliases stopTrial-StoppingMissingDose
#' @example examples/Rules-method-stopTrial-StoppingMissingDose.R
#'
setMethod(
  f = "stopTrial",
  signature = signature(
    stopping = "StoppingMissingDose",
    dose = "numeric",
    samples = "ANY",
    model = "ANY",
    data = "Data"
  ),
  definition = function(stopping, dose, samples, model, data, ...) {
    do_stop <- is.na(dose) || (data@placebo && dose == min(data@doseGrid))

    msg <- paste(
      "Next dose is",
      ifelse(
        do_stop,
        paste(
          ifelse(
            data@placebo && dose == min(data@doseGrid),
            "placebo dose",
            "NA"
          ),
          ", i.e., no active dose is safe enough according to the NextBest rule."
        ),
        "available at the dose grid."
      )
    )

    structure(do_stop,
      message = msg,
      report_label = stopping@report_label
    )
  }
)

# nolint start

## --------------------------------------------------
## Stopping based on multiple stopping rules
## --------------------------------------------------

##' @describeIn stopTrial Stop based on multiple stopping rules
##' @example examples/Rules-method-stopTrial-StoppingList.R
setMethod("stopTrial",
  signature =
    signature(
      stopping = "StoppingList",
      dose = "ANY",
      samples = "ANY",
      model = "ANY",
      data = "ANY"
    ),
  def =
    function(stopping, dose, samples, model, data, ...) {
      ## evaluate the individual stopping rules
      ## in the list
      individualResults <-
        if (missing(samples)) {
          lapply(stopping@stop_list,
            stopTrial,
            dose = dose,
            model = model,
            data = data,
            ...
          )
        } else {
          lapply(stopping@stop_list,
            stopTrial,
            dose = dose,
            samples = samples,
            model = model,
            data = data,
            ...
          )
        }

      ## summarize to obtain overall result
      overallResult <- stopping@summary(as.logical(individualResults))

      ## retrieve individual text messages,
      ## but let them in the list structure
      overallText <- lapply(individualResults, attr, "message")

      return(structure(overallResult,
        message = overallText,
        individual = individualResults
      ))
    }
)

## --------------------------------------------------
## Stopping based on fulfillment of all multiple stopping rules
## --------------------------------------------------

##' @describeIn stopTrial Stop based on fulfillment of all multiple stopping
##' rules
##'
##' @example examples/Rules-method-stopTrial-StoppingAll.R
setMethod("stopTrial",
  signature =
    signature(
      stopping = "StoppingAll",
      dose = "ANY",
      samples = "ANY",
      model = "ANY",
      data = "ANY"
    ),
  def =
    function(stopping, dose, samples, model, data, ...) {
      ## evaluate the individual stopping rules
      ## in the list
      individualResults <-
        if (missing(samples)) {
          lapply(stopping@stop_list,
            stopTrial,
            dose = dose,
            model = model,
            data = data,
            ...
          )
        } else {
          lapply(stopping@stop_list,
            stopTrial,
            dose = dose,
            samples = samples,
            model = model,
            data = data,
            ...
          )
        }

      ## summarize to obtain overall result
      overallResult <- all(as.logical(individualResults))

      ## retrieve individual text messages,
      ## but let them in the list structure
      overallText <- lapply(individualResults, attr, "message")

      return(structure(overallResult,
        message = overallText,
        individual = individualResults,
        report_label = stopping@report_label
      ))
    }
)


## --------------------------------------------------
## Stopping based on fulfillment of any stopping rule
## --------------------------------------------------

##' @describeIn stopTrial Stop based on fulfillment of any stopping rule
##'
##' @example examples/Rules-method-stopTrial-StoppingAny.R
setMethod("stopTrial",
  signature =
    signature(
      stopping = "StoppingAny",
      dose = "ANY",
      samples = "ANY",
      model = "ANY",
      data = "ANY"
    ),
  def =
    function(stopping, dose, samples, model, data, ...) {
      ## evaluate the individual stopping rules
      ## in the list
      individualResults <-
        if (missing(samples)) {
          lapply(stopping@stop_list,
            stopTrial,
            dose = dose,
            model = model,
            data = data,
            ...
          )
        } else {
          lapply(stopping@stop_list,
            stopTrial,
            dose = dose,
            samples = samples,
            model = model,
            data = data,
            ...
          )
        }

      ## summarize to obtain overall result
      overallResult <- any(as.logical(individualResults))

      ## retrieve individual text messages,
      ## but let them in the list structure
      overallText <- lapply(individualResults, attr, "message")

      return(structure(overallResult,
        message = overallText,
        individual = individualResults,
        report_label = stopping@report_label
      ))
    }
)




## --------------------------------------------------
## Stopping based on number of cohorts near to next best dose
## --------------------------------------------------

##' @describeIn stopTrial Stop based on number of cohorts near to next best dose
##'
##' @example examples/Rules-method-stopTrial-StoppingCohortsNearDose.R
setMethod("stopTrial",
  signature =
    signature(
      stopping = "StoppingCohortsNearDose",
      dose = "numeric",
      samples = "ANY",
      model = "ANY",
      data = "Data"
    ),
  def =
    function(stopping, dose, samples, model, data, ...) {
      ## determine the range where the cohorts must lie in
      lower <- (100 - stopping@percentage) / 100 * dose
      upper <- (100 + stopping@percentage) / 100 * dose

      ## which patients lie there?
      indexPatients <- which((data@x >= lower) & (data@x <= upper))

      ## how many cohorts?
      nCohorts <- length(unique(data@cohort[indexPatients]))

      ## so can we stop?
      doStop <- nCohorts >= stopping@nCohorts

      ## generate message
      text <- paste(nCohorts,
        " cohorts lie within ",
        stopping@percentage,
        "% of the next best dose ",
        dose,
        ". This ",
        ifelse(doStop, "reached", "is below"),
        " the required ",
        stopping@nCohorts,
        " cohorts",
        sep = ""
      )

      ## return both
      return(structure(doStop,
        message = text,
        report_label = stopping@report_label
      ))
    }
)


## -------------------------------------------------------------
## Stopping based on number of patients near to next best dose
## -------------------------------------------------------------

##' @describeIn stopTrial Stop based on number of patients near to next best
##' dose
##'
##' @example examples/Rules-method-stopTrial-StoppingPatientsNearDose.R
setMethod("stopTrial",
  signature =
    signature(
      stopping = "StoppingPatientsNearDose",
      dose = "numeric",
      samples = "ANY",
      model = "ANY",
      data = "Data"
    ),
  def =
    function(stopping, dose, samples, model, data, ...) {
      ## determine the range where the cohorts must lie in
      lower <- (100 - stopping@percentage) / 100 * dose
      upper <- (100 + stopping@percentage) / 100 * dose

      ## how many patients lie there?
      nPatients <- ifelse(
        is.na(dose),
        0,
        sum((data@x >= lower) & (data@x <= upper))
      )

      ## so can we stop?
      doStop <- nPatients >= stopping@nPatients

      ## generate message
      text <- paste(nPatients,
        " patients lie within ",
        stopping@percentage,
        "% of the next best dose ",
        dose,
        ". This ",
        ifelse(doStop, "reached", "is below"),
        " the required ",
        stopping@nPatients,
        " patients",
        sep = ""
      )

      ## return both
      return(structure(doStop,
        message = text,
        report_label = stopping@report_label
      ))
    }
)

## --------------------------------------------------
## Stopping based on minimum number of cohorts
## --------------------------------------------------

##' @describeIn stopTrial Stop based on minimum number of cohorts
##'
##' @example examples/Rules-method-stopTrial-StoppingMinCohorts.R
setMethod("stopTrial",
  signature =
    signature(
      stopping = "StoppingMinCohorts",
      dose = "ANY",
      samples = "ANY",
      model = "ANY",
      data = "Data"
    ),
  def =
    function(stopping, dose, samples, model, data, ...) {
      ## determine number of cohorts
      nCohorts <- length(unique(data@cohort))

      ## so can we stop?
      doStop <- nCohorts >= stopping@nCohorts

      ## generate message
      text <-
        paste(
          "Number of cohorts is",
          nCohorts,
          "and thus",
          ifelse(doStop, "reached", "below"),
          "the prespecified minimum number",
          stopping@nCohorts
        )

      ## return both
      return(structure(doStop,
        message = text,
        report_label = stopping@report_label
      ))
    }
)

## --------------------------------------------------
## Stopping based on minimum number of patients
## --------------------------------------------------

##' @describeIn stopTrial Stop based on minimum number of patients
##'
##' @example examples/Rules-method-stopTrial-StoppingMinPatients.R
setMethod("stopTrial",
  signature =
    signature(
      stopping = "StoppingMinPatients",
      dose = "ANY",
      samples = "ANY",
      model = "ANY",
      data = "Data"
    ),
  def =
    function(stopping, dose, samples, model, data, ...) {
      ## so can we stop?
      doStop <- data@nObs >= stopping@nPatients

      ## generate message
      text <-
        paste(
          "Number of patients is",
          data@nObs,
          "and thus",
          ifelse(doStop, "reached", "below"),
          "the prespecified minimum number",
          stopping@nPatients
        )

      ## return both
      return(structure(doStop,
        message = text,
        report_label = stopping@report_label
      ))
    }
)

# nolint end

## StoppingTargetProb ----

#' @describeIn stopTrial Stop based on probability of target tox interval
#'
#' @aliases stopTrial-StoppingTargetProb
#' @example examples/Rules-method-stopTrial-StoppingTargetProb.R
setMethod(
  f = "stopTrial",
  signature =
    signature(
      stopping = "StoppingTargetProb",
      dose = "numeric",
      samples = "Samples",
      model = "GeneralModel",
      data = "ANY"
    ),
  definition = function(stopping, dose, samples, model, data, ...) {
    # Compute probability to be in target interval.
    prob_target <- ifelse(
      is.na(dose),
      0,
      mean(
        prob(dose = dose, model, samples, ...) >= stopping@target[1] &
          prob(dose = dose, model, samples, ...) <= stopping@target[2]
      )
    )

    do_stop <- prob_target >= stopping@prob

    msg <- paste(
      "Probability for target toxicity is",
      round(prob_target * 100),
      "% for dose",
      dose,
      "and thus",
      ifelse(do_stop, "above", "below"),
      "the required",
      round(stopping@prob * 100),
      "%"
    )

    structure(
      do_stop,
      message = msg,
      report_label = stopping@report_label
    )
  }
)

# nolint start

## --------------------------------------------------
## Stopping based on MTD distribution
## --------------------------------------------------

##' @describeIn stopTrial Stop based on MTD distribution
##'
##' @example examples/Rules-method-stopTrial-StoppingMTDdistribution.R
setMethod("stopTrial",
  signature =
    signature(
      stopping = "StoppingMTDdistribution",
      dose = "numeric",
      samples = "Samples",
      model = "GeneralModel",
      data = "ANY"
    ),
  def =
    function(stopping, dose, samples, model, data, ...) {
      ## First, generate the MTD samples.

      ## add prior data and samples to the
      ## function environment so that they
      ## can be used.
      mtdSamples <- dose(
        x = stopping@target,
        model,
        samples,
        ...
      )

      ## what is the absolute threshold?
      absThresh <- stopping@thresh * dose

      ## what is the probability to be above this dose?
      prob <- ifelse(
        is.na(absThresh),
        0,
        mean(mtdSamples > absThresh)
      )

      ## so can we stop?
      doStop <- prob >= stopping@prob

      ## generate message
      text <-
        paste(
          "Probability of MTD above",
          round(stopping@thresh * 100),
          "% of current dose",
          dose,
          "is",
          round(prob * 100),
          "% and thus",
          ifelse(doStop, "greater than or equal to", "strictly less than"),
          "the required",
          round(stopping@prob * 100),
          "%"
        )

      ## return both
      return(structure(doStop,
        message = text,
        report_label = stopping@report_label
      ))
    }
)

# nolint end

## StoppingMTDCV ----

#' @rdname stopTrial
#'
#' @description Stopping rule based precision of the MTD estimation.
#'   The trial is stopped, when the MTD can be estimated with sufficient precision.
#'   The criteria is based on the robust coefficient of variation (CV) calculated
#'   from the posterior distribution.
#'   The robust CV is defined `mad(MTD) / median(MTD)`, where `mad` is the median
#'   absolute deviation.
#'
#' @aliases stopTrial-StoppingMTDCV
#' @example examples/Rules-method-stopTrial-StoppingMTDCV.R
#' @export
#'
setMethod(
  f = "stopTrial",
  signature = signature(
    stopping = "StoppingMTDCV",
    dose = "numeric",
    samples = "Samples",
    model = "GeneralModel",
    data = "ANY"
  ),
  definition = function(stopping, dose, samples, model, data, ...) {
    mtd_samples <- dose(
      x = stopping@target,
      model,
      samples,
      ...
    )
    # CV of MTD expressed as percentage, derived based on MTD posterior samples.
    mtd_cv <- (mad(mtd_samples) / median(mtd_samples)) * 100
    do_stop <- (mtd_cv <= stopping@thresh_cv) && (mtd_cv >= 0)

    msg <- paste(
      "CV of MTD is",
      round(mtd_cv),
      "% and thus",
      ifelse(do_stop, "below", "above"),
      "the required precision threshold of",
      round(stopping@thresh_cv),
      "%"
    )

    structure(
      do_stop,
      message = msg,
      report_label = stopping@report_label
    )
  }
)


## StoppingLowestDoseHSRBeta ----

#' @rdname stopTrial
#'
#' @description Stopping based based on the lowest non placebo dose. The trial is
#'  stopped when the lowest non placebo dose meets the Hard
#'  Safety Rule, i.e. it is deemed to be overly toxic. Stopping is based on the
#'  observed data at the lowest dose level using a Bin-Beta model
#'  based on DLT probability.
#'
#' @aliases stopTrial-StoppingLowestDoseHSRBeta
#' @example examples/Rules-method-stopTrial-StoppingLowestDoseHSRBeta.R
#' @export
setMethod(
  f = "stopTrial",
  signature = signature(
    stopping = "StoppingLowestDoseHSRBeta",
    dose = "numeric",
    samples = "Samples"
  ),
  definition = function(stopping, dose, samples, model, data, ...) {
    # Actual number of patients at first active dose.
    n <- sum(data@x == data@doseGrid[data@placebo + 1])

    # Determine toxicity probability of the first active dose.
    tox_prob_first_dose <-
      if (n > 0) {
        x <- sum(data@y[which(data@x == data@doseGrid[data@placebo + 1])])
        pbeta(stopping@target, x + stopping@a, n - x + stopping@b, lower.tail = FALSE)
      } else {
        0
      }

    do_stop <- tox_prob_first_dose > stopping@prob

    # generate message
    msg <- if (n == 0) {
      "Lowest active dose not tested, stopping rule not applied."
    } else {
      paste(
        "Probability that the lowest active dose of ",
        data@doseGrid[data@placebo + 1],
        " being toxic based on posterior Beta distribution using a Beta(",
        stopping@a, ",", stopping@b, ") prior is ",
        round(tox_prob_first_dose * 100),
        "% and thus ",
        ifelse(do_stop, "above", "below"),
        " the required ",
        round(stopping@prob * 100),
        "% threshold.",
        sep = ""
      )
    }

    structure(
      do_stop,
      message = msg,
      report_label = stopping@report_label
    )
  }
)

## StoppingTargetBiomarker ----

#' @describeIn stopTrial Stop based on probability of targeting biomarker
#'
#' @aliases stopTrial-StoppingTargetBiomarker
#' @example examples/Rules-method-stopTrial-StoppingTargetBiomarker.R
setMethod(
  f = "stopTrial",
  signature = signature(
    stopping = "StoppingTargetBiomarker",
    dose = "numeric",
    samples = "Samples",
    model = "DualEndpoint",
    data = "ANY"
  ),
  definition = function(stopping, dose, samples, model, data, ...) {
    # Compute the target biomarker prob at this dose.
    # Get the biomarker level samples at the dose grid points.
    biom_level_samples <- biomarker(xLevel = seq_len(data@nGrid), model, samples, ...)

    # If target is relative to maximum.
    if (stopping@is_relative) {
      # If there is an 'Emax' parameter, target biomarker level will
      # be relative to 'Emax', otherwise will be relative to the
      # maximum biomarker level achieved in the given dose range.
      if ("Emax" %in% names(samples)) {
        # For each sample, look which dose is maximizing the
        # simultaneous probability to be in the target biomarker
        # range and below overdose toxicity.
        prob_target <- numeric(ncol(biom_level_samples))
        prob_target <- sapply(
          seq(1, ncol(biom_level_samples)),
          function(x) {
            sum(biom_level_samples[, x] >= stopping@target[1] * samples@data$Emax &
              biom_level_samples[, x] <= stopping@target[2] * samples@data$Emax) /
              nrow(biom_level_samples)
          }
        )
      } else {
        # For each sample, look which was the minimum dose giving
        # relative target level.
        targetIndex <- apply(
          biom_level_samples, 1L,
          function(x) {
            rnx <- range(x)
            min(which(
              (x >= stopping@target[1] * diff(rnx) + rnx[1]) &
                (x <= stopping@target[2] * diff(rnx) + rnx[1] + 1e-10)
            ))
          }
        )
        prob_target <- numeric(ncol(biom_level_samples))
        tab <- table(targetIndex)
        prob_target[as.numeric(names(tab))] <- tab
        prob_target <- prob_target / nrow(biom_level_samples)
      }
    } else {
      # Otherwise the target is absolute.
      # For each sample, look which dose is maximizing the
      # simultaneous probability to be in the target biomarker
      # range and below overdose toxicity.
      prob_target <- numeric(ncol(biom_level_samples))
      prob_target <- sapply(
        seq(1, ncol(biom_level_samples)),
        function(x) {
          sum(biom_level_samples[, x] >= stopping@target[1] & biom_level_samples[, x] <= stopping@target[2]) /
            nrow(biom_level_samples)
        }
      )
    }

    prob_target <- ifelse(
      is.na(dose),
      0,
      prob_target[which(data@doseGrid == dose)]
    )

    do_stop <- prob_target >= stopping@prob

    msg <- paste(
      "Probability for target biomarker is",
      round(prob_target * 100),
      "% for dose",
      dose,
      "and thus",
      ifelse(do_stop, "above", "below"),
      "the required",
      round(stopping@prob * 100),
      "%"
    )

    structure(
      do_stop,
      message = msg,
      report_label = stopping@report_label
    )
  }
)

## StoppingSpecificDose ----

#' @describeIn stopTrial if Stopping rule is met for specific dose of the planned
#' dose grid and not just for the default next best dose.
#'
#' @aliases stopTrial-StoppingSpecificDose
#'
#' @export
#' @example examples/Rules-method-stopTrial-StoppingSpecificDose.R
#'
setMethod(
  f = "stopTrial",
  signature = signature(
    stopping = "StoppingSpecificDose",
    dose = "numeric",
    samples = "ANY",
    model = "ANY",
    data = "Data"
  ),
  definition = function(stopping, dose, samples, model, data, ...) {
    # Specific dose must be a part of the dose grid.
    assert_subset(x = stopping@dose@.Data, choices = data@doseGrid)

    # Evaluate the original (wrapped) stopping rule at the specific dose.
    result <- stopTrial(
      stopping = stopping@rule,
      dose = stopping@dose@.Data,
      samples = samples,
      model = model,
      data = data,
      ...
    )
    # Correct the text message from the original stopping rule.
    attr(result, "message") <- gsub(
      pattern = "next best",
      replacement = "specific",
      x = attr(result, "message"),
      ignore.case = TRUE
    )

    attr(result, "report_label") <- stopping@report_label

    result
  }
)

# nolint start

## --------------------------------------------------
## Stopping when the highest dose is reached
## --------------------------------------------------

##' @describeIn stopTrial Stop when the highest dose is reached
##'
##' @example examples/Rules-method-stopTrial-StoppingHighestDose.R
setMethod("stopTrial",
  signature =
    signature(
      stopping = "StoppingHighestDose",
      dose = "numeric",
      samples = "ANY",
      model = "ANY",
      data = "Data"
    ),
  def =
    function(stopping, dose, samples, model, data, ...) {
      isHighestDose <- ifelse(
        is.na(dose),
        FALSE,
        (dose == data@doseGrid[data@nGrid])
      )
      return(structure(isHighestDose,
        message =
          paste(
            "Next best dose is", dose, "and thus",
            ifelse(isHighestDose, "the",
              "not the"
            ),
            "highest dose"
          ),
        report_label = stopping@report_label
      ))
    }
)

## StoppingOrdinal ----

#' @describeIn stopTrial Stop based on value returned by next best dose.
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' @aliases stopTrial-StoppingOrdinal
#' @example examples/Rules-method-stopTrial-StoppingOrdinal.R
#'
setMethod(
  f = "stopTrial",
  signature = signature(
    stopping = "StoppingOrdinal",
    dose = "numeric",
    samples = "ANY",
    model = "LogisticLogNormalOrdinal",
    data = "DataOrdinal"
  ),
  definition = function(stopping, dose, samples, model, data, ...) {
    stopTrial(
      stopping = stopping@rule,
      dose = dose,
      samples = h_convert_ordinal_samples(samples, stopping@grade),
      model = h_convert_ordinal_model(model, stopping@grade),
      data = h_convert_ordinal_data(data, stopping@grade),
      ...
    )
  }
)

#' @describeIn stopTrial Stop based on value returned by next best dose.
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' @aliases stopTrial-StoppingOrdinal
#' @example examples/Rules-method-stopTrial-StoppingOrdinal.R
#'
setMethod(
  f = "stopTrial",
  signature = signature(
    stopping = "StoppingOrdinal",
    dose = "numeric",
    samples = "ANY",
    model = "ANY",
    data = "ANY"
  ),
  definition = function(stopping, dose, samples, model, data, ...) {
    stop(
      paste0(
        "StoppingOrdinal objects can only be used with LogisticLogNormalOrdinal ",
        "models and DataOrdinal data objects. In this case, the model is a '",
        class(model),
        "' object and the data is in a ",
        class(data),
        " object."
      )
    )
  }
)


## ============================================================

## --------------------------------------------------
## "MAX" combination of cohort size rules
## --------------------------------------------------

##' "MAX" combination of cohort size rules
##'
##' This function combines cohort size rules by taking
##' the maximum of all sizes.
##'
##' @param \dots Objects of class \code{\linkS4class{CohortSize}}
##' @return the combination as an object of class
##' \code{\linkS4class{CohortSizeMax}}
##'
##' @seealso \code{\link{minSize}}
##' @export
##' @keywords methods
setGeneric("maxSize",
  def =
    function(...) {
      ## there should be no default method,
      ## therefore just forward to next method!
      standardGeneric("maxSize")
    },
  valueClass = "CohortSizeMax"
)

##' @describeIn maxSize The method combining cohort size rules by taking maximum
##' @example examples/Rules-method-maxSize.R
setMethod("maxSize",
  "CohortSize",
  def =
    function(...) {
      CohortSizeMax(list(...))
    }
)

## --------------------------------------------------
## "MIN" combination of cohort size rules
## --------------------------------------------------

##' "MIN" combination of cohort size rules
##'
##' This function combines cohort size rules by taking
##' the minimum of all sizes.
##'
##' @param \dots Objects of class \code{\linkS4class{CohortSize}}
##' @return the combination as an object of class
##' \code{\linkS4class{CohortSizeMin}}
##'
##' @seealso \code{\link{maxSize}}
##' @export
##' @keywords methods
setGeneric("minSize",
  def =
    function(...) {
      ## there should be no default method,
      ## therefore just forward to next method!
      standardGeneric("minSize")
    },
  valueClass = "CohortSizeMin"
)

##' @describeIn minSize The method combining cohort size rules by taking minimum
##' @example examples/Rules-method-minSize.R
setMethod("minSize",
  "CohortSize",
  def =
    function(...) {
      CohortSizeMin(list(...))
    }
)

# size ----

## CohortSizeRange ----

#' @describeIn size Determines the size of the next cohort based on the range
#'   into which the next dose falls into.
#'
#' @param dose the next dose.
#' @param data the data input, an object of class [`Data`].
#'
#' @aliases size-CohortSizeRange
#' @example examples/Rules-method-size-CohortSizeRange.R
#'
setMethod(
  f = "size",
  signature = signature(
    object = "CohortSizeRange"
  ),
  definition = function(object, dose, data) {
    # If the recommended next dose is NA, don't check it and return 0.
    if (is.na(dose)) {
      return(0L)
    }
    assert_class(data, "Data")

    # Determine in which interval the next dose is.
    interval <- findInterval(x = dose, vec = object@intervals)
    object@cohort_size[interval]
  }
)

## CohortSizeDLT ----

#' @describeIn size Determines the size of the next cohort based on the number
#'   of DLTs so far.
#'
#' @param dose the next dose.
#' @param data the data input, an object of class [`Data`].
#'
#' @aliases size-CohortSizeDLT
#' @example examples/Rules-method-size-CohortSizeDLT.R
#'
setMethod(
  f = "size",
  signature = signature(
    object = "CohortSizeDLT"
  ),
  definition = function(object, dose, data) {
    # If the recommended next dose is NA, don't check it and return 0.
    if (is.na(dose)) {
      return(0L)
    }
    assert_class(data, "Data")

    # Determine how many DLTs have occurred so far.
    dlt_happened <- sum(data@y)

    # Determine in which interval this is.
    interval <- findInterval(x = dlt_happened, vec = object@intervals)
    object@cohort_size[interval]
  }
)

## CohortSizeMax ----

#' @describeIn size Determines the size of the next cohort based on maximum of
#'   multiple cohort size rules.
#'
#' @param dose the next dose.
#' @param data the data input, an object of class [`Data`].
#'
#' @aliases size-CohortSizeMax
#' @example examples/Rules-method-size-CohortSizeMax.R
#'
setMethod(
  f = "size",
  signature = signature(
    object = "CohortSizeMax"
  ),
  definition = function(object, dose, data) {
    # If the recommended next dose is NA, don't check it and return 0.
    if (is.na(dose)) {
      return(0L)
    }
    assert_class(data, "Data")

    # Evaluate the individual cohort size rules in the list.
    individual_results <- sapply(
      object@cohort_sizes,
      size,
      dose = dose,
      data = data
    )
    # The overall result.
    max(individual_results)
  }
)

## CohortSizeMin ----

#' @describeIn size Determines the size of the next cohort based on minimum of
#'   multiple cohort size rules.
#'
#' @param dose the next dose.
#' @param data the data input, an object of class [`Data`].
#'
#' @aliases size-CohortSizeMin
#' @example examples/Rules-method-size-CohortSizeMin.R
#'
setMethod(
  f = "size",
  signature = signature(
    object = "CohortSizeMin"
  ),
  definition = function(object, dose, data) {
    # If the recommended next dose is NA, don't check it and return 0.
    if (is.na(dose)) {
      return(0L)
    }
    assert_class(data, "Data")

    # Evaluate the individual cohort size rules in the list.
    individual_results <- sapply(
      object@cohort_sizes,
      size,
      dose = dose,
      data = data
    )
    # The overall result.
    min(individual_results)
  }
)

## CohortSizeConst ----

#' @describeIn size Constant cohort size.
#'
#' @param dose the next dose.
#' @param ... not used.
#'
#' @aliases size-CohortSizeConst
#' @example examples/Rules-method-size-CohortSizeConst.R
#'
setMethod(
  f = "size",
  signature = signature(
    object = "CohortSizeConst"
  ),
  definition = function(object, dose, ...) {
    # If the recommended next dose is NA, don't check it and return 0.
    if (is.na(dose)) {
      0L
    } else {
      object@size
    }
  }
)

## CohortSizeParts ----

#' @describeIn size Determines the size of the next cohort based on the parts.
#'
#' @param dose the next dose.
#' @param data the data input, an object of class [`Data`].
#'
#' @aliases size-CohortSizeParts
#' @example examples/Rules-method-size-CohortSizeParts.R
#'
setMethod(
  f = "size",
  signature = signature(
    object = "CohortSizeParts"
  ),
  definition = function(object, dose, data) {
    # If the recommended next dose is NA, don't check it and return 0.
    if (is.na(dose)) {
      return(0L)
    } else {
      assert_class(data, "DataParts")
      object@cohort_sizes[data@nextPart]
    }
  }
)

## CohortSizeOrdinal ----

#' @describeIn size Determines the size of the next cohort in a ordinal CRM trial.
#'
#' @param  dose (`numeric`) the next dose.
#' @param data the data input, an object of class [`DataOrdinal`].
#'
#' @aliases size-CohortSizeOrdinal
#' @example examples/Rules-method-size-CohortSizeOrdinal.R
#'
setMethod(
  f = "size",
  signature = signature(
    object = "CohortSizeOrdinal"
  ),
  definition = function(object, dose, data, ...) {
    # Validate
    assert_numeric(dose, len = 1, lower = 0)
    assert_class(data, "DataOrdinal")
    # Execute

    size(
      object@rule,
      dose = dose,
      data = h_convert_ordinal_data(data, object@grade),
      ...
    )
  }
)

## ------------------------------------------------------------------------------------------------
## Stopping based on a target ratio of the upper to the lower 95% credibility interval
## ------------------------------------------------------------------------------------------------
##' @describeIn stopTrial Stop based on 'StoppingTDCIRatio' class when
##' reaching the target ratio of the upper to the lower 95% credibility
##' interval of the estimate (TDtargetEndOfTrial). This is a stopping rule which incorporate only
##' DLE responses and DLE samples are given
##'
##' @example examples/Rules-method-stopTrialCITDsamples.R
##'
##' @export
##' @keywords methods
setMethod(
  f = "stopTrial",
  signature = signature(
    stopping = "StoppingTDCIRatio",
    dose = "ANY",
    samples = "Samples",
    model = "ModelTox",
    data = "ANY"
  ),
  definition = function(stopping, dose, samples, model, data, ...) {
    assert_probability(stopping@prob_target)

    dose_target_samples <- dose(
      x = stopping@prob_target,
      model = model,
      samples = samples,
      ...
    )
    # 95% credibility interval.
    dose_target_ci <- quantile(dose_target_samples, probs = c(0.025, 0.975))
    dose_target_ci_ratio <- dose_target_ci[[2]] / dose_target_ci[[1]]

    do_stop <- dose_target_ci_ratio <= stopping@target_ratio
    text <- paste0(
      "95% CI is (",
      paste(dose_target_ci, collapse = ", "),
      "), Ratio = ",
      round(dose_target_ci_ratio, 4),
      " is ",
      ifelse(do_stop, "less than or equal to ", "greater than "),
      "target_ratio = ", stopping@target_ratio
    )
    structure(do_stop,
      message = text,
      report_label = stopping@report_label
    )
  }
)

## ----------------------------------------------------------------------------------------------
## Stopping based on a target ratio of the upper to the lower 95% credibility interval
## ------------------------------------------------------------------------------------------------
##' @describeIn stopTrial Stop based on 'StoppingTDCIRatio' class
##' when reaching the target ratio of the upper to the lower 95% credibility
##' interval of the estimate (TDtargetEndOfTrial). This is a stopping rule which incorporate only
##' DLE responses and no DLE samples are involved
##' @example examples/Rules-method-stopTrialCITD.R
setMethod("stopTrial",
  signature =
    signature(
      stopping = "StoppingTDCIRatio",
      dose = "ANY",
      samples = "missing",
      model = "ModelTox",
      data = "ANY"
    ),
  def =
    function(stopping, dose, model, data, ...) {
      assert_probability(stopping@prob_target)

      prob_target <- stopping@prob_target
      dose_target_samples <- dose(x = prob_target, model = model, ...)
      ## Find the variance of the log of the dose_target_samples(eta)
      M1 <- matrix(c(-1 / (model@phi2), -(log(prob_target / (1 - prob_target)) - model@phi1) / (model@phi2)^2), 1, 2)
      M2 <- model@Pcov
      varEta <- as.vector(M1 %*% M2 %*% t(M1))

      ## Find the upper and lower limit of the 95% credibility interval
      CI <- exp(log(dose_target_samples) + c(-1, 1) * 1.96 * sqrt(varEta))
      ratio <- CI[2] / CI[1]

      ## so can we stop?
      doStop <- ratio <= stopping@target_ratio
      ## generate message
      text <- paste(
        "95% CI is (", round(CI[1], 4), ",", round(CI[2], 4), "), Ratio =", round(ratio, 4), "is ", ifelse(doStop, "is less than or equal to", "greater than"),
        "target_ratio =", stopping@target_ratio
      )
      ## return both
      return(structure(
        doStop,
        message = text,
        report_label = stopping@report_label
      ))
    }
)

## --------------------------------------------------------------------------------------------------
## Stopping based on a target ratio of the upper to the lower 95% credibility interval
## ------------------------------------------------------------------------------------------------
##' @describeIn stopTrial Stop based on reaching the target ratio of the upper to the lower 95% credibility
##' interval of the estimate (the minimum of Gstar and TDtargetEndOfTrial). This is a stopping rule which
##' incorporate DLE and efficacy responses and DLE and efficacy samples are also used.
##'
##' @param TDderive the function which derives from the input, a vector of the posterior samples called
##' \code{TDsamples} of the dose
##' which has the probability of the occurrence of DLE equals to either the targetDuringTrial or
##' targetEndOfTrial, the final next best TDtargetDuringTrial (the dose with probability of the
##' occurrence of DLE equals to the targetDuringTrial)and TDtargetEndOfTrial estimate.
##' @param Effmodel the efficacy model of \code{\linkS4class{ModelEff}} class object
##' @param Effsamples the efficacy samples of \code{\linkS4class{Samples}} class object
##' @param Gstarderive the function which derives from the input, a vector of the posterior Gstar (the dose
##' which gives the maximum gain value) samples
##' called \code{Gstarsamples}, the final next best Gstar estimate.
##'
##' @example examples/Rules-method-stopTrialCIMaxGainSamples.R
setMethod("stopTrial",
  signature =
    signature(
      stopping = "StoppingMaxGainCIRatio",
      dose = "ANY",
      samples = "Samples",
      model = "ModelTox",
      data = "DataDual"
    ),
  def =
    function(stopping, dose, samples, model, data, TDderive, Effmodel, Effsamples, Gstarderive, ...) {
      prob_target <- stopping@prob_target

      ## checks
      assert_probability(prob_target)
      stopifnot(is(Effmodel, "ModelEff"))
      stopifnot(is(Effsamples, "Samples"))
      stopifnot(is.function(TDderive))
      stopifnot(is.function(Gstarderive))

      ## find the TDtarget End of Trial samples
      TDtargetEndOfTrialSamples <- dose(
        x = prob_target,
        model = model,
        samples = samples,
        ...
      )
      ## Find the TDtarget End of trial estimate
      TDtargetEndOfTrialEstimate <- TDderive(TDtargetEndOfTrialSamples)

      ## Find the gain value samples then the GstarSamples
      points <- data@doseGrid

      GainSamples <- matrix(
        nrow = size(samples),
        ncol = length(points)
      )

      ## evaluate the probs, for all gain samples.
      for (i in seq_along(points))
      {
        ## Now we want to evaluate for the
        ## following dose:
        GainSamples[, i] <- gain(
          dose = points[i],
          model,
          samples,
          Effmodel,
          Effsamples,
          ...
        )
      }

      ## Find the maximum gain value samples
      MaxGainSamples <- apply(GainSamples, 1, max)

      ## Obtain Gstar samples, samples for the dose level which gives the maximum gain value
      IndexG <- apply(GainSamples, 1, which.max)
      GstarSamples <- data@doseGrid[IndexG]

      ## Find the Gstar estimate

      Gstar <- Gstarderive(GstarSamples)
      ## Find the 95% credibility interval of Gstar and its ratio of the upper to the lower limit
      CIGstar <- quantile(GstarSamples, probs = c(0.025, 0.975))
      ratioGstar <- as.numeric(CIGstar[2] / CIGstar[1])

      ## Find the 95% credibility interval of TDtargetEndOfTrial and its ratio of the upper to the lower limit
      CITDEOT <- quantile(TDtargetEndOfTrialSamples, probs = c(0.025, 0.975))
      ratioTDEOT <- as.numeric(CITDEOT[2] / CITDEOT[1])

      ## Find which is smaller (TDtargetEndOfTrialEstimate or Gstar)

      if (TDtargetEndOfTrialEstimate <= Gstar) {
        ## Find the upper and lower limit of the 95% credibility interval and its ratio of the smaller
        CI <- CITDEOT
        ratio <- ratioTDEOT
        chooseTD <- TRUE
      } else {
        CI <- CIGstar
        ratio <- ratioGstar
        chooseTD <- FALSE
      }

      ## so can we stop?
      doStop <- ratio <= stopping@target_ratio
      ## generate message
      text1 <- paste(
        "Gstar estimate is", round(Gstar, 4), "with 95% CI (", round(CIGstar[1], 4), ",", round(CIGstar[2], 4),
        ") and its ratio =",
        round(ratioGstar, 4)
      )
      text2 <- paste(
        "TDtargetEndOfTrial estimate is ", round(TDtargetEndOfTrialEstimate, 4),
        "with 95% CI (", round(CITDEOT[1], 4), ",", round(CITDEOT[2], 4), ") and its ratio=",
        round(ratioTDEOT, 4)
      )
      text3 <- paste(
        ifelse(chooseTD, "TDatrgetEndOfTrial estimate", "Gstar estimate"), "is smaller with ratio =",
        round(ratio, 4), " which is ", ifelse(doStop, "is less than or equal to", "greater than"),
        "target_ratio =", stopping@target_ratio
      )
      text <- c(text1, text2, text3)
      ## return both
      return(structure(doStop,
        message = text,
        report_label = stopping@report_label
      ))
    }
)

## -----------------------------------------------------------------------------------------------
## Stopping based on a target ratio of the upper to the lower 95% credibility interval
## --------------------------------------------------------------------------------------------
##' @describeIn stopTrial Stop based on reaching the target ratio of the upper to the lower 95% credibility
##' interval of the estimate (the minimum of Gstar and TDtargetEndOfTrial). This is a stopping rule which
##' incorporate DLE and efficacy responses without DLE and efficacy samples involved.
##' @example examples/Rules-method-stopTrialCIMaxGain.R
setMethod("stopTrial",
  signature =
    signature(
      stopping = "StoppingMaxGainCIRatio",
      dose = "ANY",
      samples = "missing",
      model = "ModelTox",
      data = "DataDual"
    ),
  def =
    function(stopping, dose, model, data, Effmodel, ...) {
      prob_target <- stopping@prob_target

      ## checks
      assert_probability(prob_target)
      stopifnot(is(Effmodel, "ModelEff"))


      ## find the TDtarget End of Trial
      TDtargetEndOfTrial <- dose(
        x = prob_target,
        model = model,
        ...
      )

      ## Find the dose with maximum gain value
      Gainfun <- function(DOSE) {
        -gain(DOSE, model_dle = model, model_eff = Effmodel, ...)
      }

      # if(data@placebo) {
      # n <- length(data@doseGrid)
      # LowestDose <- sort(data@doseGrid)[2]} else {
      LowestDose <- min(data@doseGrid)
      # }

      Gstar <- (optim(LowestDose, Gainfun, method = "L-BFGS-B", lower = LowestDose, upper = max(data@doseGrid))$par)
      MaxGain <- -(optim(LowestDose, Gainfun, method = "L-BFGS-B", lower = LowestDose, upper = max(data@doseGrid))$value)
      if (data@placebo) {
        logGstar <- log(Gstar + Effmodel@const)
      } else {
        logGstar <- log(Gstar)
      }



      ## From paper (Yeung et. al 2015)

      meanEffGstar <- Effmodel@theta1 + Effmodel@theta2 * log(logGstar)

      denom <- (model@phi2) * (meanEffGstar) * (1 + logGstar * model@phi2)

      dgphi1 <- -(meanEffGstar * logGstar * model@phi2 - Effmodel@theta2) / denom

      dgphi2 <- -((meanEffGstar) * logGstar + meanEffGstar * (logGstar)^2 * model@phi2 - Effmodel@theta2 * logGstar) / denom

      dgtheta1 <- -(logGstar * model@phi2) / denom

      dgtheta2 <- -(logGstar * exp(model@phi1 + model@phi2 * logGstar) * model@phi2 * log(logGstar) - 1 - exp(model@phi1 + model@phi2 * logGstar)) / denom

      # DLEPRO <- exp(model@phi1+model@phi2*logGstar)

      # dgphi1 <- Effmodel@theta2*DLEPRO - logGstar*model@phi2*meanEffGstar*DLEPRO

      # dgphi2 <- logGstar*DLEPRO *(Effmodel@theta2-(meanEffGstar)+model@phi2)

      # dgtheta1 <- -logGstar*DLEPRO*model@phi2

      # dgtheta2 <- 1+DLEPRO-logGstar*DLEPRO*model@phi2*log(logGstar)

      deltaG <- matrix(c(dgphi1, dgphi2, dgtheta1, dgtheta2), 4, 1)


      ## Find the variance of the log Gstar
      ## First find the covariance matrix of all the parameters, phi1, phi2, theta1 and theta2
      ## such that phi1 and phi2 and independent of theta1 and theta2
      emptyMatrix <- matrix(0, 2, 2)
      covBETA <- cbind(rbind(model@Pcov, emptyMatrix), rbind(emptyMatrix, Effmodel@Pcov))
      varlogGstar <- as.vector(t(deltaG) %*% covBETA %*% deltaG)

      ## Find the upper and lower limit of the 95% credibility interval of Gstar
      CIGstar <- exp(logGstar + c(-1, 1) * 1.96 * sqrt(varlogGstar))

      ## The ratio of the upper to the lower 95% credibility interval
      ratioGstar <- CIGstar[2] / CIGstar[1]

      ## Find the variance of the log of the TDtargetEndOfTrial(eta)
      M1 <- matrix(c(-1 / (model@phi2), -(log(prob_target / (1 - prob_target)) - model@phi1) / (model@phi2)^2), 1, 2)
      M2 <- model@Pcov

      varEta <- as.vector(M1 %*% M2 %*% t(M1))

      ## Find the upper and lower limit of the 95% credibility interval of
      ## TDtargetEndOfTrial
      CITDEOT <- exp(log(TDtargetEndOfTrial) + c(-1, 1) * 1.96 * sqrt(varEta))

      ## The ratio of the upper to the lower 95% credibility interval
      ratioTDEOT <- CITDEOT[2] / CITDEOT[1]

      if (Gstar <= TDtargetEndOfTrial) {
        chooseTD <- FALSE
        CI <- c()
        CI[2] <- CIGstar[2]
        CI[1] <- CIGstar[1]
        ratio <- ratioGstar
      } else {
        chooseTD <- TRUE
        CI <- c()
        CI[2] <- CITDEOT[2]
        CI[1] <- CITDEOT[1]
        ratio <- ratioTDEOT
      }
      ## so can we stop?
      doStop <- ratio <= stopping@target_ratio
      ## generate message

      text1 <- paste(
        "Gstar estimate is", round(Gstar, 4), "with 95% CI (", round(CIGstar[1], 4), ",", round(CIGstar[2], 4),
        ") and its ratio =",
        round(ratioGstar, 4)
      )
      text2 <- paste(
        "TDtargetEndOfTrial estimate is ", round(TDtargetEndOfTrial, 4),
        "with 95% CI (", round(CITDEOT[1], 4), ",", round(CITDEOT[2], 4), ") and its ratio=",
        round(ratioTDEOT, 4)
      )
      text3 <- paste(
        ifelse(chooseTD, "TDatrgetEndOfTrial estimate", "Gstar estimate"), "is smaller with ratio =",
        round(ratio, 4), "which is ", ifelse(doStop, "is less than or equal to", "greater than"),
        "target_ratio =", stopping@target_ratio
      )
      text <- c(text1, text2, text3)
      ## return both
      return(structure(doStop,
        message = text,
        report_label = stopping@report_label
      ))
    }
)


## ============================================================

## -----------------------------------------------------
## Determine the safety window length of the next cohort
## -----------------------------------------------------

##' Determine the safety window length of the next cohort
##'
##' This function determines the safety window length of
##' the next cohort.
##'
##' @param safetyWindow The rule, an object of class
##' \code{\linkS4class{SafetyWindow}}
##' @param size The next cohort size
##' @param data The data input, an object of class \code{\linkS4class{DataDA}}
##' @param \dots additional arguments
##'
##' @return the `windowLength` as a list of safety window parameters
##' (`gap`, `follow`, `follow_min`)
##'
##' @export
##' @keywords methods
setGeneric("windowLength",
  def =
    function(safetyWindow, size, ...) {
      ## there should be no default method,
      ## therefore just forward to next method!
      standardGeneric("windowLength")
    },
  valueClass = "list"
)


## ============================================================

## --------------------------------------------------
## The SafetyWindowSize method
## --------------------------------------------------

##' @describeIn windowLength Determine safety window length based
##' on the cohort size
##'
##' @example examples/Rules-method-windowLength-SafetyWindowSize.R
setMethod("windowLength",
  signature =
    signature(
      safetyWindow = "SafetyWindowSize",
      size = "ANY"
    ),
  def =
    function(safetyWindow, size, data, ...) {
      ## determine in which interval the next size is
      interval <-
        findInterval(
          x = size,
          vec = safetyWindow@size
        )

      ## so the safety window length is
      patientGap <- head(c(
        0, safetyWindow@gap[[interval]],
        rep(tail(safetyWindow@gap[[interval]], 1), 100)
      ), size)
      patientFollow <- safetyWindow@follow
      patientFollowMin <- safetyWindow@follow_min

      ret <- list(patientGap = patientGap, patientFollow = patientFollow, patientFollowMin = patientFollowMin)

      return(ret)
    }
)

## ============================================================

## --------------------------------------------------
## Constant safety window length
## --------------------------------------------------

##' @describeIn windowLength Constant safety window length
##' @example examples/Rules-method-windowLength-SafetyWindowConst.R
setMethod("windowLength",
  signature =
    signature(
      safetyWindow = "SafetyWindowConst",
      size = "ANY"
    ),
  def =
    function(safetyWindow, size, ...) {
      ## first element should be 0.
      patientGap <- head(c(
        0, safetyWindow@gap,
        rep(tail(safetyWindow@gap, 1), 100)
      ), size)
      patientFollow <- safetyWindow@follow
      patientFollowMin <- safetyWindow@follow_min

      ret <- list(
        patientGap = patientGap,
        patientFollow = patientFollow,
        patientFollowMin = patientFollowMin
      )

      return(ret)
    }
)

# nolint end

# tidy ----

## tidy-IncrementsRelative ----

#' @rdname tidy
#' @aliases tidy-IncrementsRelative
#' @example examples/Rules-method-tidyIncrementsRelative.R
#' @export
setMethod(
  f = "tidy",
  signature = signature(x = "IncrementsRelative"),
  definition = function(x, ...) {
    h_tidy_all_slots(x) %>%
      dplyr::bind_cols() %>%
      h_range_to_minmax(.data$intervals) %>%
      dplyr::filter(max > 0) %>%
      tibble::add_column(increment = x@increments) %>%
      h_tidy_class(x)
  }
)

## tidy-CohortSizeDLT ----

#' @rdname tidy
#' @aliases tidy-CohortSizeDLT
#' @example examples/Rules-method-tidyCohortSizeDLT.R
#' @export
setMethod(
  f = "tidy",
  signature = signature(x = "CohortSizeDLT"),
  definition = function(x, ...) {
    h_tidy_all_slots(x) %>%
      dplyr::bind_cols() %>%
      h_range_to_minmax(.data$intervals) %>%
      dplyr::filter(max > 0) %>%
      tibble::add_column(cohort_size = x@cohort_size) %>%
      h_tidy_class(x)
  }
)

## tidy-CohortSizeMin ----

#' @rdname tidy
#' @aliases tidy-CohortSizeMin
#' @example examples/Rules-method-tidyCohortSizeMin.R
#' @export
setMethod(
  f = "tidy",
  signature = signature(x = "CohortSizeMin"),
  definition = function(x, ...) {
    callNextMethod() %>% h_tidy_class(x)
  }
)

## tidy-CohortSizeMax ----

#' @rdname tidy
#' @aliases tidy-CohortSizeMax
#' @example examples/Rules-method-tidyCohortSizeMax.R
#' @export
setMethod(
  f = "tidy",
  signature = signature(x = "CohortSizeMax"),
  definition = function(x, ...) {
    callNextMethod() %>% h_tidy_class(x)
  }
)

## tidy-CohortSizeRange ----

#' @rdname tidy
#' @aliases tidy-CohortSizeRange
#' @example examples/Rules-method-tidyCohortSizeRange.R
#' @export
setMethod(
  f = "tidy",
  signature = signature(x = "CohortSizeRange"),
  definition = function(x, ...) {
    h_tidy_all_slots(x) %>%
      dplyr::bind_cols() %>%
      h_range_to_minmax(.data$intervals) %>%
      dplyr::filter(max > 0) %>%
      tibble::add_column(cohort_size = x@cohort_size) %>%
      h_tidy_class(x)
  }
)

## tidy-CohortSizeParts ----

#' @rdname tidy
#' @aliases tidy-CohortSizeParts
#' @example examples/Rules-method-tidyCohortSizeParts.R
#' @export
setMethod(
  f = "tidy",
  signature = signature(x = "CohortSizeParts"),
  definition = function(x, ...) {
    tibble::tibble(
      part = seq_along(x@cohort_sizes),
      cohort_size = x@cohort_sizes
    ) %>%
      h_tidy_class(x)
  }
)

## tidy-IncrementsMin ----

#' @rdname tidy
#' @aliases tidy-IncrementsMin
#' @example examples/Rules-method-tidyIncrementsMin.R
#' @export
setMethod(
  f = "tidy",
  signature = signature(x = "IncrementsMin"),
  definition = function(x, ...) {
    callNextMethod() %>% h_tidy_class(x)
  }
)

## tidy-IncrementsRelative ----

#' @rdname tidy
#' @aliases tidy-IncrementsRelative
#' @example examples/Rules-method-tidyIncrementsRelative.R
#' @export
setMethod(
  f = "tidy",
  signature = signature(x = "IncrementsRelative"),
  definition = function(x, ...) {
    h_tidy_all_slots(x) %>%
      h_range_to_minmax(.data$intervals) %>%
      dplyr::filter(dplyr::row_number() > 1) %>%
      tibble::add_column(increment = x@increments) %>%
      h_tidy_class(x)
  }
)

## tidy-IncrementsRelativeDLT ----

#' @rdname tidy
#' @aliases tidy-IncrementsRelativeDLT
#' @example examples/Rules-method-tidyIncrementsRelativeDLT.R
#' @export
setMethod(
  f = "tidy",
  signature = signature(x = "IncrementsRelativeDLT"),
  definition = function(x, ...) {
    h_tidy_all_slots(x) %>%
      h_range_to_minmax(.data$intervals) %>%
      dplyr::filter(dplyr::row_number() > 1) %>%
      tibble::add_column(increment = x@increments) %>%
      h_tidy_class(x)
  }
)

## tidy-IncrementsRelative ----

#' @rdname tidy
#' @aliases tidy-IncrementsRelativeParts
#' @example examples/Rules-method-tidyIncrementsRelativeParts.R
#' @export
setMethod(
  f = "tidy",
  signature = signature(x = "IncrementsRelativeParts"),
  definition = function(x, ...) {
    slot_names <- slotNames(x)
    rv <- list()
    for (nm in slot_names) {
      if (!is.function(slot(x, nm))) {
        rv[[nm]] <- h_tidy_slot(x, nm, ...)
      }
    }
    # Column bind of all list elements have the same number of rows.
    if (length(rv) > 1 & length(unique(sapply(rv, nrow))) == 1) {
      rv <- rv %>% dplyr::bind_cols()
    }
    rv <- rv %>% h_tidy_class(x)
    if (length(rv) == 1) {
      rv[[names(rv)[1]]] %>% h_tidy_class(x)
    } else {
      rv
    }
  }
)

## tidy-NextBestNCRM ----

#' @rdname tidy
#' @aliases tidy-NextBestNCRM
#' @example examples/Rules-method-tidyNextBestNCRM.R
#' @export
setMethod(
  f = "tidy",
  signature = signature(x = "NextBestNCRM"),
  definition = function(x, ...) {
    h_tidy_all_slots(x) %>%
      dplyr::bind_cols() %>%
      h_range_to_minmax(.data$target, range_min = 0, range_max = 1) %>%
      add_column(max_prob = c(NA, NA, x@max_overdose_prob)) %>%
      add_column(Range = c("Underdose", "Target", "Overdose"), .before = 1) %>%
      h_tidy_class(x)
  }
)

## tidy-NextBestNCRMLoss ----

#' @rdname tidy
#' @aliases tidy-NextBestNCRMLoss
#' @example examples/Rules-method-tidyNextBestNCRMLoss.R
#' @export
setMethod(
  f = "tidy",
  signature = signature(x = "NextBestNCRMLoss"),
  definition = function(x, ...) {
    slot_names <- slotNames(x)
    rv <- list()
    for (nm in slot_names) {
      if (!is.function(slot(x, nm))) {
        rv[[nm]] <- h_tidy_slot(x, nm, ...)
      }
    }
    # Column bind of all list elements have the same number of rows
    if (length(rv) > 1 & length(unique(sapply(rv, nrow))) == 1) {
      rv <- rv %>% dplyr::bind_cols()
    }
    rv <- rv %>% h_tidy_class(x)
    if (length(rv) == 1) {
      rv[[names(rv)[1]]] %>% h_tidy_class(x)
    } else {
      rv
    }
  }
)

#' @include McmcOptions-class.R
#' @include Model-methods.R
#' @include fromQuantiles.R
NULL

# size ----

## Samples ----

#' @describeIn size get the number of MCMC samples from `Samples` object.
#' @aliases size-Samples
#'
#' @export
#' @example examples/Samples-methods-size.R
#'
setMethod(
  f = "size",
  signature = signature(object = "Samples"),
  definition = function(object, ...) {
    size(object@options)
  }
)

# names ----

## Samples ----

#' The Names of the Sampled Parameters
#'
#' @description `r lifecycle::badge("stable")`
#'
#' A method that returns names of the parameters that are sampled.
#'
#' @param x (`Samples`)\cr object with samples.
#'
#' @aliases names-Samples
#' @export
#' @example examples/Samples-methods-names.R
#'
setMethod(
  f = "names",
  signature = signature(x = "Samples"),
  definition = function(x) {
    names(x@data)
  }
)

## --------------------------------------------------
## Extract certain parameter from "Samples" object to produce
## plots with "ggmcmc" package
## --------------------------------------------------

# The next line is required to suppress the message "Creating a generic function
# for ‘get’ from package ‘base’ in package ‘crmPack’" on package load.
# See https://github.com/Roche/crmPack/issues/723
setGeneric("get")

#' Get specific parameter samples and produce a data.frame
#'
#' Here you have to specify with \code{pos} which
#' parameter you would like to extract from the \code{\linkS4class{Samples}}
#' object
#'
#' @param x the \code{\linkS4class{Samples}} object
#' @param pos the name of the parameter
#' @param envir for vectorial parameters, you can give the indices of the
#' elements you would like to extract. If \code{NULL}, the whole vector samples
#' will be returned
#' @param mode not used
#' @param inherits not used
#'
#' @return the data frame suitable for use with \code{\link[ggmcmc]{ggmcmc}}
#'
#' @example examples/Sample-methods-get.R
#' @export
#' @keywords methods
setMethod("get",
  signature =
    signature(
      x = "Samples",
      pos = "character",
      envir = "ANY",
      mode = "ANY",
      inherits = "ANY"
    ),
  def =
    function(x,
             pos,
             envir = NULL,
             mode = NULL,
             inherits = NULL) {
      ## check the parameter name
      assert_scalar(pos)
      assert_choice(pos, names(x))

      ## get the samples for this parameter
      d <- x@data[[pos]]
      ## this can be either a vector or a matrix

      ## how many parameters do we have?
      nPars <- NCOL(d)

      ## what are the names of all parameter
      ## elements?
      elements <-
        if (nPars == 1L) {
          pos
        } else {
          paste(pos,
            "[", seq_len(nPars), "]",
            sep = ""
          )
        }

      ## in case we have a vector parameter
      if (nPars > 1L) {
        ## what are the indices to be returned?
        indices <-
          if (is.null(envir)) {
            seq_along(elements)
          } else {
            assert_integer(envir)
            assert_subset(envir, seq_along(elements))
          }

        ## subset the data matrix and par names appropriately
        d <- d[, indices, drop = FALSE]
        elements <- elements[indices]

        ## and also reduce the number of parameters
        nPars <- length(indices)
      }

      ## now we can build
      ret <- data.frame(
        Iteration = seq_len(NROW(d)),
        Chain = 1L,
        Parameter =
          factor(rep(elements, each = NROW(d)),
            levels = elements
          ),
        value = as.numeric(d)
      )

      ## add the attributes
      ret <- structure(ret,
        nChains = 1L,
        nParameters = nPars,
        nIterations = x@options@iterations,
        nBurnin = x@options@burnin,
        nThin = x@options@step,
        description = elements,
        parallel = FALSE
      )
      return(ret)
    }
)


## --------------------------------------------------
## Get fitted curves from Samples
## --------------------------------------------------

#' Fit method for the Samples class
#'
#' Note this new generic function is necessary because the \code{\link{fitted}}
#' function only allows the first argument \code{object} to appear in the
#' signature. But we need also other arguments in the signature.
#'
#' @param object the \code{\linkS4class{Samples}} object
#' @param model the \code{\linkS4class{GeneralModel}} object
#' @param data the \code{\linkS4class{Data}} object
#' @param \dots passed down to the [prob()] method.
#' @return the data frame with required information (see method details)
#'
#' @export
#' @keywords methods
setGeneric("fit",
  def =
    function(object,
             model,
             data,
             ...) {
      ## there should be no default method,
      ## therefore just forward to next method!
      standardGeneric("fit")
    },
  valueClass = "data.frame"
)


## --------------------------------------------------
## Get fitted dose-tox curve from Samples
## --------------------------------------------------

#' @param points at which dose levels is the fit requested? default is the dose
#' grid
#' @param quantiles the quantiles to be calculated (default: 0.025 and
#' 0.975)
#' @param middle the function for computing the middle point. Default:
#' \code{\link{mean}}
#'
#' @describeIn fit This method returns a data frame with dose, middle, lower
#' and upper quantiles for the dose-toxicity curve
#' @example examples/Sample-methods-fit.R
#'
setMethod("fit",
  signature =
    signature(
      object = "Samples",
      model = "GeneralModel",
      data = "Data"
    ),
  def =
    function(object,
             model,
             data,
             points = data@doseGrid,
             quantiles = c(0.025, 0.975),
             middle = mean,
             ...) {
      ## some checks
      assert_probability_range(quantiles)
      assert_numeric(points)

      ## first we have to get samples from the dose-tox
      ## curve at the dose grid points.
      probSamples <- matrix(
        nrow = size(object),
        ncol = length(points)
      )

      ## evaluate the probs, for all samples.
      for (i in seq_along(points)) {
        ## Now we want to evaluate for the
        ## following dose:
        probSamples[, i] <- prob(
          dose = points[i],
          model,
          object,
          ...
        )
      }

      ## extract middle curve
      middleCurve <- apply(probSamples, 2L, FUN = middle)

      ## extract quantiles
      quantCurve <- apply(probSamples, 2L, quantile,
        prob = quantiles
      )

      ## now create the data frame
      ret <- data.frame(
        dose = points,
        middle = middleCurve,
        lower = quantCurve[1, ],
        upper = quantCurve[2, ]
      )

      ## return it
      return(ret)
    }
)

## --------------------------------------------------
## Get fitted dose-tox and dose-biomarker curves from Samples
## --------------------------------------------------

#' @describeIn fit This method returns a data frame with dose, and middle,
#' lower and upper quantiles, for both the dose-tox and dose-biomarker (suffix
#' "Biomarker") curves, for all grid points (Note that currently only the grid
#' points can be used, because the DualEndpointRW models only allow that)
#'
#' @example examples/Sample-methods-fit-DualEndpoint.R
setMethod("fit",
  signature =
    signature(
      object = "Samples",
      model = "DualEndpoint",
      data = "DataDual"
    ),
  def =
    function(object,
             model,
             data,
             quantiles = c(0.025, 0.975),
             middle = mean,
             ...) {
      ## some checks
      assert_probability_range(quantiles)

      ## first obtain the dose-tox curve results from the parent method
      start <- callNextMethod(
        object = object,
        model = model,
        data = data,
        points = data@doseGrid,
        quantiles = quantiles,
        middle = middle,
        ...
      )

      ## now obtain the dose-biomarker results

      ## get the biomarker level samples
      ## at the dose grid points.
      biomLevelSamples <- biomarker(xLevel = seq_len(data@nGrid), model, samples = object)

      ## extract middle curve
      middleCurve <- apply(biomLevelSamples, 2L, FUN = middle)

      ## extract quantiles
      quantCurve <- apply(biomLevelSamples, 2L, quantile,
        prob = quantiles
      )

      ## now create the data frame
      biomResults <- data.frame(
        middleBiomarker = middleCurve,
        lowerBiomarker = quantCurve[1, ],
        upperBiomarker = quantCurve[2, ]
      )

      ## return both, pasted together
      return(cbind(start, biomResults))
    }
)

## --------------------------------------------------
## Approximate posterior with (log) normal distribution
## --------------------------------------------------

#' Approximate posterior with (log) normal distribution
#'
#' To reproduce the resultant approximate model in the future exactly, include
#' \code{seed = xxxx} in the call to `approximate`.
#'
#' @param object the \code{\linkS4class{Samples}} object
#' @param model the \code{\linkS4class{GeneralModel}} object
#' @param data the \code{\linkS4class{Data}} object
#' @param \dots additional arguments (see methods)
#' @return a `list` containing the approximation model and, if requested, a
#' `ggplot2` object containing a graphical representation of the fitted model
#'
#' @export
#' @keywords methods
setGeneric("approximate",
  def =
    function(object, model, data, ...) {
      ## there should be no default method,
      ## therefore just forward to next method!
      standardGeneric("approximate")
    },
  valueClass = "list"
)


##' @param points optional parameter, which gives the dose values at which
##' the approximation should rely on (default: 5 values equally spaced from
##' minimum to maximum of the dose grid)
##' @param refDose the reference dose to be used (default: median of
##' \code{points})
##' @param logNormal use the log-normal prior? (not default) otherwise, the
##' normal prior for the logistic regression coefficients is used
##' @param verbose be verbose (progress statements)? (default)
##' @param create_plot add a `ggplot2` object to the return value (default)
##'
##' @describeIn approximate Here the \dots argument can transport additional arguments for
##' \code{\link{Quantiles2LogisticNormal}}, e.g. in order to control the
##' approximation quality, etc.
##'
##' @example examples/Sample-methods-approximate.R
setMethod("approximate",
  signature =
    signature(object = "Samples"),
  def =
    function(object,
             model,
             data,
             points =
               seq(
                 from = min(data@doseGrid),
                 to = max(data@doseGrid),
                 length = 5L
               ),
             refDose = median(points),
             logNormal = FALSE,
             verbose = TRUE,
             create_plot = TRUE,
             ...) {
      # Validation
      assert_logical(logNormal)
      assert_logical(verbose)
      assert_logical(create_plot)
      assert_numeric(points)
      assert_numeric(refDose)
      ## get the required quantiles at these dose levels:
      quants <- fit(object,
        model,
        data,
        points = points,
        quantiles = c(0.025, 0.975),
        middle = median
      )

      ## get better starting values if it is already a logistic normal
      ## model
      if (is(model, "LogisticNormal") && (!logNormal)) {
        means <- sapply(
          object@data,
          mean
        )
        cov <- cov(as.data.frame(object@data))

        parstart <- c(
          means[1], means[2],
          sqrt(cov[1, 1]), sqrt(cov[2, 2]),
          cov2cor(cov)[1, 2]
        )
      } else if (is(model, "LogisticLogNormal") && logNormal) {
        datTrafo <- with(
          object@data,
          cbind(
            alpha0,
            log(alpha1)
          )
        )

        means <- colMeans(datTrafo)
        cov <- cov(datTrafo)

        parstart <- c(
          means[1], means[2],
          sqrt(cov[1, 1]), sqrt(cov[2, 2]),
          cov2cor(cov)[1, 2]
        )
      } else {
        parstart <- NULL
      }

      ## run the approx function
      quantRes <- Quantiles2LogisticNormal(
        dosegrid = quants$dose,
        refDose = refDose,
        lower = quants$lower,
        upper = quants$upper,
        median = quants$middle,
        verbose = verbose,
        parstart = parstart,
        logNormal = logNormal,
        ...
      )
      rv <- list()
      rv$model <- quantRes$model
      if (create_plot) {
        rv$plot <- tibble::as_tibble(quantRes$required) %>%
          tibble::add_column(Type = "original") %>%
          tibble::add_column(x = points) %>%
          dplyr::bind_rows(
            tibble::as_tibble(quantRes$quantiles) %>%
              tibble::add_column(Type = "approximation") %>%
              tibble::add_column(x = points)
          ) %>%
          tidyr::pivot_longer(
            c(lower, median, upper),
            names_to = "Line",
            values_to = "y"
          ) %>%
          ggplot(
            aes(
              x = x,
              y = y,
              colour = Type,
              group = interaction(Type, .data$Line),
              linetype = (.data$Line == "median")
            )
          ) +
          geom_line() +
          scale_colour_manual(
            name = " ",
            values = c("red", "blue")
          ) +
          scale_linetype_manual(
            name = " ",
            values = c("dotted", "solid"),
            labels = c("95% CI", "Median"),
            guide = guide_legend(reverse = TRUE)
          ) +
          labs(
            x = "Dose",
            y = "p(Tox)"
          ) +
          theme_light()
      }

      ## return the results
      return(rv)
    }
)

## --------------------------------------------------
## Plot dose-tox fit from a model
## --------------------------------------------------


#' Plotting dose-toxicity model fits
#'
#' @param x the \code{\linkS4class{Samples}} object
#' @param y the \code{\linkS4class{GeneralModel}} object
#' @param data the \code{\linkS4class{Data}} object
#' @param xlab the x axis label
#' @param ylab the y axis label
#' @param showLegend should the legend be shown? (default)
#' @param \dots not used
#' @return This returns the \code{\link[ggplot2]{ggplot}}
#' object for the dose-toxicity model fit
#'
#' @example examples/Sample-methods-plot.R
#' @export
setMethod("plot",
  signature =
    signature(
      x = "Samples",
      y = "GeneralModel"
    ),
  def =
    function(x, y, data, ...,
             xlab = "Dose level",
             ylab = "Probability of DLT [%]",
             showLegend = TRUE) {
      ## check args
      assert_logical(showLegend)

      ## get the fit
      plotData <- fit(x,
        model = y,
        data = data,
        quantiles = c(0.025, 0.975),
        middle = mean,
        ...
      )

      ## make the plot
      gdata <-
        with(
          plotData,
          data.frame(
            x = rep(dose, 3),
            y = c(middle, lower, upper) * 100,
            group =
              rep(c("mean", "lower", "upper"),
                each = nrow(plotData)
              ),
            Type =
              factor(
                c(
                  rep(
                    "Estimate",
                    nrow(plotData)
                  ),
                  rep(
                    "95% Credible Interval",
                    nrow(plotData) * 2
                  )
                ),
                levels =
                  c(
                    "Estimate",
                    "95% Credible Interval"
                  )
              )
          )
        )

      ret <- gdata %>% ggplot() +
        geom_line(
          aes(
            x = x,
            y = y,
            group = group,
            linetype = Type,
          ),
          colour = I("red"),
        ) +
        coord_cartesian(ylim = c(0, 100)) +
        labs(
          x = xlab,
          y = ylab,
        )

      ret <- ret +
        scale_linetype_manual(
          breaks =
            c(
              "Estimate",
              "95% Credible Interval"
            ),
          values = c(1, 2), guide = ifelse(showLegend, "legend", "none")
        )

      return(ret)
    }
)


## --------------------------------------------------
## Special method for dual endpoint model
## --------------------------------------------------


#' Plotting dose-toxicity and dose-biomarker model fits
#'
#' When we have the dual endpoint model,
#' also the dose-biomarker fit is shown in the plot
#'
#' @param x the \code{\linkS4class{Samples}} object
#' @param y the \code{\linkS4class{DualEndpoint}} object
#' @param data the \code{\linkS4class{DataDual}} object
#' @param extrapolate should the biomarker fit be extrapolated to the whole
#' dose grid? (default)
#' @param showLegend should the legend be shown? (not default)
#' @param \dots additional arguments for the parent method
#' \code{\link{plot,Samples,GeneralModel-method}}
#' @return This returns the \code{\link[ggplot2]{ggplot}}
#' object with the dose-toxicity and dose-biomarker model fits
#'
#' @example examples/Sample-methods-plot-DualEndpoint.R
#' @export
setMethod("plot",
  signature =
    signature(
      x = "Samples",
      y = "DualEndpoint"
    ),
  def =
    function(x, y, data, extrapolate = TRUE, showLegend = FALSE, ...) {
      assert_logical(extrapolate)

      ## call the superclass method, to get the toxicity plot
      plot1 <- callNextMethod(x, y, data, showLegend = showLegend, ...)

      ## only look at these dose levels for the plot:
      xLevels <-
        if (extrapolate) {
          seq_along(data@doseGrid)
        } else {
          1:max(data@xLevel)
        }

      ## get the plot data for the biomarker plot
      functionSamples <- biomarker(xLevel = xLevels, model = y, samples = x)

      ## extract mean curve
      meanCurve <- colMeans(functionSamples)

      ## extract quantiles
      quantiles <- c(0.025, 0.975)
      quantCurve <- apply(functionSamples, 2L, quantile,
        prob = quantiles
      )

      ## now create the data frame
      plotData <- data.frame(
        dose = data@doseGrid[xLevels],
        mean = meanCurve,
        lower = quantCurve[1, ],
        upper = quantCurve[2, ]
      )

      ## make the second plot
      gdata <-
        with(
          plotData,
          data.frame(
            x = rep(dose, 3),
            y = c(mean, lower, upper),
            group =
              rep(c("mean", "lower", "upper"),
                each = nrow(plotData)
              ),
            Type =
              factor(
                c(
                  rep(
                    "Estimate",
                    nrow(plotData)
                  ),
                  rep(
                    "95% Credible Interval",
                    nrow(plotData) * 2
                  )
                ),
                levels =
                  c(
                    "Estimate",
                    "95% Credible Interval"
                  )
              )
          )
        )
      plot2 <- gdata %>% ggplot() +
        geom_line(
          aes(
            x = x,
            y = y,
            group = group,
            linetype = Type
          ),
          colour = I("blue")
        ) +
        labs(
          x = "Dose level",
          y = "Biomarker level"
        )

      plot2 <- plot2 +
        scale_linetype_manual(
          breaks =
            c(
              "Estimate",
              "95% Credible Interval"
            ),
          values = c(1, 2),
          guide = ifelse(showLegend, "legend", "none")
        )

      ## arrange both plots side by side
      ret <- gridExtra::arrangeGrob(plot1, plot2, ncol = 2)
      return(ret)
    }
)


## -------------------------------------------------------------------------------------
## Get fitted dose-tox curve from Samples for 'LogisticIndepBeta' model class
## ------------------------------------------------------------------------------------
#' @describeIn fit This method return a data frame with dose, middle lower and upper quantiles
#' for the dose-DLE curve using DLE samples for \dQuote{LogisticIndepBeta} model class
#' @example examples/Samples-method-fitDLE.R
setMethod("fit",
  signature =
    signature(
      object = "Samples",
      model = "LogisticIndepBeta",
      data = "Data"
    ),
  def =
    function(object,
             model,
             data,
             points = data@doseGrid,
             quantiles = c(0.025, 0.975),
             middle = mean,
             ...) {
      ## some checks
      assert_probability_range(quantiles)
      assert_numeric(points)

      ## first we have to get samples from the dose-tox
      ## curve at the dose grid points.
      probSamples <- matrix(
        nrow = size(object),
        ncol = length(points)
      )

      ## evaluate the probs, for all samples.
      for (i in seq_along(points)) {
        ## Now we want to evaluate for the
        ## following dose:
        probSamples[, i] <- prob(
          dose = points[i],
          model,
          object
        )
      }

      ## extract middle curve
      middleCurve <- apply(probSamples, 2L, FUN = middle)

      ## extract quantiles
      quantCurve <- apply(probSamples, 2L, quantile,
        prob = quantiles
      )

      ## now create the data frame
      ret <- data.frame(
        dose = points,
        middle = middleCurve,
        lower = quantCurve[1, ],
        upper = quantCurve[2, ]
      )

      ## return it
      return(ret)
    }
)

## -------------------------------------------------------------------------------------
## Get fitted dose-efficacy curve from Samples for 'Effloglog' model class
## ------------------------------------------------------------------------------------

#' @describeIn fit This method returns a data frame with dose, middle, lower, upper quantiles for
#' the dose-efficacy curve using efficacy samples for \dQuote{Effloglog} model class
#' @example examples/Samples-method-fitEff.R
setMethod("fit",
  signature =
    signature(
      object = "Samples",
      model = "Effloglog",
      data = "DataDual"
    ),
  def =
    function(object,
             model,
             data,
             points = data@doseGrid,
             quantiles = c(0.025, 0.975),
             middle = mean,
             ...) {
      ## some checks
      assert_probability_range(quantiles)
      assert_numeric(points)

      ## first we have to get samples from the dose-tox
      ## curve at the dose grid points.
      ExpEffSamples <- matrix(
        nrow = size(object),
        ncol = length(points)
      )

      ## evaluate the probs, for all samples.
      for (i in seq_along(points)) {
        ## Now we want to evaluate for the
        ## following dose:
        ExpEffSamples[, i] <- efficacy(
          dose = points[i],
          model,
          object
        )
      }

      ## extract middle curve
      middleCurve <- apply(ExpEffSamples, 2L, FUN = middle)

      ## extract quantiles
      quantCurve <- apply(ExpEffSamples, 2L, quantile,
        prob = quantiles
      )

      ## now create the data frame
      ret <- data.frame(
        dose = points,
        middle = middleCurve,
        lower = quantCurve[1, ],
        upper = quantCurve[2, ]
      )

      ## return it
      return(ret)
    }
)
## ==========================================================================================
## --------------------------------------------------------------------
## Get fitted dose-efficacy based on the Efficacy Flexible model
## -------------------------------------------------------------
#' @describeIn fit This method returns a data frame with dose, middle, lower and upper
#' quantiles for the dose-efficacy curve using efficacy samples for \dQuote{EffFlexi}
#' model class
#' @example examples/Samples-method-fitEffFlexi.R
setMethod("fit",
  signature =
    signature(
      object = "Samples",
      model = "EffFlexi",
      data = "DataDual"
    ),
  def =
    function(object,
             model,
             data,
             points = data@doseGrid,
             quantiles = c(0.025, 0.975),
             middle = mean,
             ...) {
      ## some checks
      assert_probability_range(quantiles)
      assert_numeric(points)

      ## first we have to get samples from the dose-tox
      ## curve at the dose grid points.
      ExpEffSamples <- matrix(
        nrow = size(object),
        ncol = length(points)
      )

      ## evaluate the probs, for all samples.
      for (i in seq_along(points)) {
        ## Now we want to evaluate for the
        ## following dose:
        ExpEffSamples[, i] <- efficacy(
          dose = points[i],
          model,
          object
        )
      }

      ## extract middle curve
      middleCurve <- apply(ExpEffSamples, 2L, FUN = middle)

      ## extract quantiles
      quantCurve <- apply(ExpEffSamples, 2L, quantile,
        prob = quantiles
      )

      ## now create the data frame
      ret <- data.frame(
        dose = points,
        middle = middleCurve,
        lower = quantCurve[1, ],
        upper = quantCurve[2, ]
      )

      ## return it
      return(ret)
    }
)

#' @describeIn fit This method returns a data frame with dose, middle, lower
#' and upper quantiles for the dose-efficacy curve using efficacy samples
#' for the \dQuote{LogisticLogNormalOrdinal} model class
#' @example examples/Sample-methods-fit-LogisticLogNormalOrdinal.R
setMethod(
  "fit",
  signature = signature(
    object = "Samples",
    model = "LogisticLogNormalOrdinal",
    data = "DataOrdinal"
  ),
  def = function(object,
                 model,
                 data,
                 points = data@doseGrid,
                 quantiles = c(0.025, 0.975),
                 middle = mean,
                 ...) {
    # Validation
    assert_probability_range(quantiles)
    assert_numeric(points)
    assert_function(middle)

    # Begin
    # Get samples from the dose-tox curve at the dose grid points.
    probSamples <- matrix(
      nrow = size(object),
      ncol = length(points)
    )
    # Evaluate the probs, for all samples.
    for (i in seq_along(points)) {
      # Now we want to evaluate for the following dose:
      probSamples[, i] <- prob(
        dose = points[i],
        model,
        object,
        ...
      )
    }
    # Extract middle curve
    middleCurve <- apply(probSamples, 2L, FUN = middle)
    # Extract quantiles
    quantCurve <- apply(probSamples, 2L, quantile, prob = quantiles)

    # Create the data frame...
    ret <- data.frame(
      dose = points,
      middle = middleCurve,
      lower = quantCurve[1, ],
      upper = quantCurve[2, ]
    )

    # ...and return it
    return(ret)
  }
)
## ==============================================================
## ----------------------------------------------------------------
## Get fitted values at all dose levels from gain samples
## -----------------------------------------------------------------
#' Get the fitted values for the gain values at all dose levels based on
#' a given pseudo DLE model, DLE sample, a pseudo efficacy model, a Efficacy sample
#' and data. This method returns a data frame with dose, middle, lower and upper quantiles
#' of the gain value samples
#'
#' @param DLEmodel the DLE pseudo model of \code{\linkS4class{ModelTox}} class object
#' @param DLEsamples the DLE samples of \code{\linkS4class{Samples}} class object
#' @param Effmodel the efficacy pseudo model of \code{\linkS4class{ModelEff}} class object
#' @param Effsamples the efficacy samples of \code{\linkS4class{Samples}} class object
#' @param data the data input of \code{\linkS4class{DataDual}} class object
#' @param \dots additional arguments for methods
#'
#' @export
#' @keywords methods
#' @example examples/Samples-method-fitGain.R
setGeneric("fitGain",
  def =
    function(DLEmodel,
             DLEsamples,
             Effmodel,
             Effsamples,
             data,
             ...) {
      ## there should be no default method,
      ## therefore just forward to next method!
      standardGeneric("fitGain")
    },
  valueClass = "data.frame"
)

#' @describeIn fitGain This method returns a data frame with dose, middle, lower, upper quantiles for
#' the gain values obtained given the DLE and the efficacy samples
#' @param points at which dose levels is the fit requested? default is the dose
#' grid
#' @param quantiles the quantiles to be calculated (default: 0.025 and
#' 0.975)
#' @param middle the function for computing the middle point. Default:
#' \code{\link{mean}}
#' @example examples/Samples-method-fitGain.R
setMethod("fitGain",
  signature =
    signature(
      DLEmodel = "ModelTox",
      DLEsamples = "Samples",
      Effmodel = "ModelEff",
      Effsamples = "Samples",
      data = "DataDual"
    ),
  def =
    function(DLEmodel,
             DLEsamples,
             Effmodel,
             Effsamples,
             data,
             points = data@doseGrid,
             quantiles = c(0.025, 0.975),
             middle = mean,
             ...) {
      ## some checks
      assert_probability_range(quantiles)
      assert_numeric(points)

      ## first we have to get samples from the gain
      ## at the dose grid points.
      GainSamples <- matrix(
        nrow = size(DLEsamples),
        ncol = length(points)
      )

      ## evaluate the probs, for all gain samples.
      for (i in seq_along(points)) {
        ## Now we want to evaluate for the
        ## following dose:
        GainSamples[, i] <- gain(
          dose = points[i],
          DLEmodel,
          DLEsamples,
          Effmodel,
          Effsamples
        )
      }

      ## extract middle curve
      middleCurve <- apply(GainSamples, 2L, FUN = middle)

      ## extract quantiles
      quantCurve <- apply(GainSamples, 2L, quantile,
        prob = quantiles
      )

      ## now create the data frame
      ret <- data.frame(
        dose = points,
        middle = middleCurve,
        lower = quantCurve[1, ],
        upper = quantCurve[2, ]
      )

      ## return it
      return(ret)
    }
)
## ---------------------------------------------------------------------------------
## Plot the fitted dose-DLE curve with pseudo DLE model with samples
## -------------------------------------------------------------------------------
#' Plot the fitted dose-DLE curve using a \code{\linkS4class{ModelTox}} class model with samples
#'
#' @param x the \code{\linkS4class{Samples}} object
#' @param y the \code{\linkS4class{ModelTox}} model class object
#' @param data the \code{\linkS4class{Data}} object
#' @param xlab the x axis label
#' @param ylab the y axis label
#' @param showLegend should the legend be shown? (default)
#' @param \dots not used
#' @return This returns the \code{\link[ggplot2]{ggplot}}
#' object for the dose-DLE model fit
#'
#' @example examples/Samples-method-plotModelTox.R
#' @export
#' @keywords methods
setMethod("plot",
  signature =
    signature(
      x = "Samples",
      y = "ModelTox"
    ),
  def =
    function(x, y, data, ...,
             xlab = "Dose level",
             ylab = "Probability of DLT [%]",
             showLegend = TRUE) {
      ## check args
      assert_logical(showLegend)


      ## get the fit
      plotData <- fit(x,
        model = y,
        data = data,
        quantiles = c(0.025, 0.975),
        middle = mean
      )

      ## make the plot
      gdata <-
        with(
          plotData,
          data.frame(
            x = rep(dose, 3),
            y = c(middle, lower, upper) * 100,
            group =
              rep(c("mean", "lower", "upper"),
                each = nrow(plotData)
              ),
            Type =
              factor(
                c(
                  rep(
                    "Estimate",
                    nrow(plotData)
                  ),
                  rep(
                    "95% Credible Interval",
                    nrow(plotData) * 2
                  )
                ),
                levels =
                  c(
                    "Estimate",
                    "95% Credible Interval"
                  )
              )
          )
        )

      ret <- gdata %>% ggplot() +
        geom_line(
          aes(
            x = x,
            y = y,
            group = group,
            linetype = Type
          ),
          colour = I("red"),
        ) +
        coord_cartesian(ylim = c(0, 100)) +
        labs(
          x = xlab,
          y = ylab
        )

      ret <- ret +
        scale_linetype_manual(
          breaks =
            c(
              "Estimate",
              "95% Credible Interval"
            ),
          values = c(1, 2), guide = ifelse(showLegend, "legend", "none")
        )

      return(ret)
    }
)


# --------------------------------------------------------------------------------------------
## Plot the fitted dose-efficacy curve using a pseudo efficacy model with samples
## -------------------------------------------------------------------------------------------
#' Plot the fitted dose-efficacy curve using a model from \code{\linkS4class{ModelEff}} class
#' with samples
#'
#' @param x the \code{\linkS4class{Samples}} object
#' @param y the \code{\linkS4class{ModelEff}} model class object
#' @param data the \code{\linkS4class{Data}} object
#' @param xlab the x axis label
#' @param ylab the y axis label
#' @param showLegend should the legend be shown? (default)
#' @param \dots not used
#' @return This returns the \code{\link[ggplot2]{ggplot}}
#' object for the dose-efficacy model fit
#'
#' @example examples/Samples-method-plotModelEff.R
#' @export
#' @keywords methods
setMethod("plot",
  signature =
    signature(
      x = "Samples",
      y = "ModelEff"
    ),
  def =
    function(x, y, data, ...,
             xlab = "Dose level",
             ylab = "Expected Efficacy",
             showLegend = TRUE) {
      ## check args
      assert_logical(showLegend)

      ## get the fit
      plotData <- fit(x,
        model = y,
        data = data,
        quantiles = c(0.025, 0.975),
        middle = mean
      )

      ## make the plot
      gdata <-
        with(
          plotData,
          data.frame(
            x = rep(dose, 3),
            y = c(middle, lower, upper),
            group =
              rep(c("mean", "lower", "upper"),
                each = nrow(plotData)
              ),
            Type =
              factor(
                c(
                  rep(
                    "Estimate",
                    nrow(plotData)
                  ),
                  rep(
                    "95% Credible Interval",
                    nrow(plotData) * 2
                  )
                ),
                levels =
                  c(
                    "Estimate",
                    "95% Credible Interval"
                  )
              )
          )
        )

      ret <- gdata %>% ggplot() +
        geom_line(
          aes(
            x = x,
            y = y,
            group = group,
            linetype = Type
          ),
          colour = I("blue")
        ) +
        labs(
          x = xlab,
          y = ylab
        ) +
        coord_cartesian(xlim = c(0, max(data@doseGrid)))

      ret <- ret +
        scale_linetype_manual(
          breaks =
            c(
              "Estimate",
              "95% Credible Interval"
            ),
          values = c(1, 2), guide = ifelse(showLegend, "legend", "none")
        )

      return(ret)
    }
)

## ----------------------------------------------------------------------------------------
## Plot of fitted dose-DLE curve based on a pseudo DLE model without sample
## -------------------------------------------------------------------------------------
#' Plot of the fitted dose-tox based with a given pseudo DLE model and data without samples
#'
#' @param x the data of \code{\linkS4class{Data}} class object
#' @param y the model of the \code{\linkS4class{ModelTox}} class object
#' @param xlab the x axis label
#' @param ylab the y axis label
#' @param showLegend should the legend be shown? (default)
#' @param \dots not used
#' @return This returns the \code{\link[ggplot2]{ggplot}}
#' object for the dose-DLE model plot
#'
#' @example examples/Samples-method-plotModelToxNoSamples.R
#' @export
#' @keywords methods
setMethod("plot",
  signature =
    signature(
      x = "Data",
      y = "ModelTox"
    ),
  def =
    function(x, y,
             xlab = "Dose level",
             ylab = "Probability of DLE",
             showLegend = TRUE, ...) {
      ## check args
      assert_logical(showLegend)

      ## Make sure the right model estimates are use with the given data
      y <- update(object = y, data = x)


      ## create data frame

      plotData <- data.frame(
        dose = x@doseGrid,
        probDLE = prob(
          dose = x@doseGrid,
          model = y
        )
      )
      ## Look for TD30 and TD35
      TD30 <- dose(
        x = 0.30,
        model = y
      )
      TD35 <- dose(
        x = 0.35,
        model = y
      )

      ## make the plot
      gdata <- with(
        plotData,
        data.frame(
          x = dose,
          y = probDLE,
          group = rep("Estimated DLE", each = nrow(plotData)),
          Type = factor(rep("Estimated DLE", nrow(plotData)), levels = "Estimated DLE")
        )
      )

      plot1 <- gdata %>% ggplot() +
        geom_line(
          aes(
            x = x,
            y = y,
            group = group,
            linetype = Type
          ),
          colour = I("red"),
          linewidth = 1.5
        ) +
        labs(
          x = xlab,
          y = ylab
        ) +
        coord_cartesian(ylim = c(0, 1)) +
        scale_linetype_manual(
          breaks = "Estimated DLE",
          values = c(1, 2),
          guide = ifelse(showLegend, "legend", "none")
        )
      return(plot1)
    }
)


## ---------------------------------------------------------------------------------------------
## Plot the fitted dose-efficacy curve given a pseudo efficacy model without samples
## ----------------------------------------------------------------------------------
#' Plot of the fitted dose-efficacy based with a given pseudo efficacy model and data without samples
#'
#' @param x the data of \code{\linkS4class{DataDual}} class object
#' @param y the model of the \code{\linkS4class{ModelEff}} class object
#' @param xlab the x axis label
#' @param ylab the y axis label
#' @param showLegend should the legend be shown? (default)
#' @param \dots not used
#' @return This returns the \code{\link[ggplot2]{ggplot}}
#' object for the dose-efficacy model plot
#'
#' @example examples/Samples-method-plotModelEffNoSamples.R
#' @export
#' @keywords methods
setMethod("plot",
  signature =
    signature(
      x = "DataDual",
      y = "ModelEff"
    ),
  def =
    function(x, y, ...,
             xlab = "Dose level",
             ylab = "Expected Efficacy",
             showLegend = TRUE) {
      ## check args
      assert_logical(showLegend)
      y <- update(object = y, data = x)

      ## create data frame

      plotEffData <- data.frame(
        dose = x@doseGrid,
        ExpEff = efficacy(
          dose = x@doseGrid,
          model = y
        )
      )

      ## make the second plot
      ggdata <- with(
        plotEffData,
        data.frame(
          x = dose,
          y = ExpEff,
          group = rep("Estimated Expected Efficacy", each = nrow(plotEffData)),
          Type = factor(rep("Estimated Expected Efficacy", nrow(plotEffData)), levels = "Estimated Expected Efficacy")
        )
      )

      ## Get efficacy plot
      plot2 <- ggplot(data = ggdata, aes(x = x, y = y), group = group) +
        xlab("Dose Levels") +
        ylab(paste("Estimated Expected Efficacy")) +
        xlim(c(0, max(x@doseGrid))) +
        geom_line(colour = I("blue"), linewidth = 1.5)

      plot2 <- plot2 +
        geom_line(linewidth = 1.5, colour = "blue")


      return(plot2)
    }
)

## ----------------------------------------------------------------------------------------------------------
## Plot the gain curve using a pseudo DLE and a pseudo Efficacy model with samples
## ----------------------------------------------------------------------------------------------------
#' Plot the gain curve in addition with the dose-DLE and dose-efficacy curve using a given DLE pseudo model,
#' a DLE sample, a given efficacy pseudo model and an efficacy sample
#'
#' @param DLEmodel the dose-DLE model of \code{\linkS4class{ModelTox}} class object
#' @param DLEsamples the DLE sample of \code{\linkS4class{Samples}} class object
#' @param Effmodel the dose-efficacy model of \code{\linkS4class{ModelEff}} class object
#' @param Effsamples the efficacy sample of of \code{\linkS4class{Samples}} class object
#' @param data the data input of \code{\linkS4class{DataDual}} class object
#' @param \dots not used
#' @return This returns the \code{\link[ggplot2]{ggplot}}
#' object for the plot
#'
#' @example examples/Samples-method-plotGain.R
#' @export
#' @keywords methods
setGeneric("plotGain",
  def =
    function(DLEmodel,
             DLEsamples,
             Effmodel,
             Effsamples,
             data, ...) {
      standardGeneric("plotGain")
    }
)
#' @describeIn plotGain Standard method
setMethod("plotGain",
  signature =
    signature(
      DLEmodel = "ModelTox",
      DLEsamples = "Samples",
      Effmodel = "ModelEff",
      Effsamples = "Samples"
    ),
  def =
    function(DLEmodel, DLEsamples, Effmodel, Effsamples, data, ...) {
      ## Get fitted values for probabilities of DLE at all dose levels

      plotDLEData <- fit(DLEsamples,
        model = DLEmodel,
        data = data,
        quantiles = c(0.025, 0.975),
        middle = mean
      )

      ## Get fitted values for mean efficacy values at all dose levels
      plotEffData <- fit(Effsamples,
        model = Effmodel,
        data = data,
        quantiles = c(0.025, 0.975),
        middle = mean
      )

      ## Get fitted values for gain values at all dose levels
      plotGainData <- fitGain(
        DLEmodel = DLEmodel,
        DLEsamples = DLEsamples,
        Effmodel = Effmodel,
        Effsamples = Effsamples,
        data = data
      )

      ## For each of the dose levels, take the mean for the probabilties of DLE, mean efiicacy values
      ## and gain values. Hence combine them into a data frame

      plotData <- data.frame(
        dose = rep(data@doseGrid, 3),
        values = c(
          plotDLEData$middle,
          plotEffData$middle,
          plotGainData$middle
        )
      )
      ## only the line plots for the mean value of the DLE, efficacy and gain samples
      ## at all dose levels
      gdata <- with(
        plotData,
        data.frame(
          x = dose,
          y = values,
          group = c(
            rep("p(DLE)", length(data@doseGrid)),
            rep("Mean Expected Efficacy", length(data@doseGrid)),
            rep("Gain", length(data@doseGrid))
          ),
          Type = factor("Estimate", levels = "Estimate")
        )
      )

      plot1 <- ggplot(data = gdata, aes(x = x, y = y)) +
        geom_line(aes(group = group, color = group), linewidth = 1.5) +
        scale_colour_manual(name = "curves", values = c("green3", "blue", "red")) +
        xlab("Dose Level") +
        xlim(c(0, max(data@doseGrid))) +
        ylab(paste("Values")) +
        ylim(c(min(gdata$y), max(gdata$y)))
      return(plot1)
    }
)

## ----------------------------------------------------------------------------------------------------
## Plot the gain curve using a pseudo DLE and a pseudo Efficacy model without samples
## ----------------------------------------------------------------------------------------------------
#' Plot the gain curve in addition with the dose-DLE and dose-efficacy curve using a given DLE pseudo model,
#' and a given efficacy pseudo model
#'
#' @describeIn plotGain Standard method
#' @param size (`integer`)\cr a vector of length two defining the sizes of
#' the shapes used to identify the doses with, respectively, p(DLE = 0.3) and the
#' maximum gain
#' @param shape (`integer`)\cr a vector of length two defining the shapes
#' used to identify the doses with, respectively, p(DLE = 0.3) and the maximum gain
#'
#' @example examples/Samples-method-plotGainNoSamples.R
#' @export
#' @keywords methods
setMethod("plotGain",
  signature =
    signature(
      DLEmodel = "ModelTox",
      DLEsamples = "missing",
      Effmodel = "ModelEff",
      Effsamples = "missing"
    ),
  def =
    function(DLEmodel, Effmodel, data, size = c(8L, 8L), shape = c(16L, 17L), ...) {
      assert_integer(size, len = 2, any.missing = FALSE, lower = 0, upper = 20)
      assert_integer(shape, len = 2, any.missing = FALSE, unique = TRUE, lower = 0, upper = 25)
      ## Make sure the model estimates are corresponds to the input data
      DLEmodel <- update(object = DLEmodel, data = data)
      Effmodel <- update(object = Effmodel, data = data)

      plotData <- data.frame(
        dose = rep(data@doseGrid, 3),
        values = c(
          prob(
            dose = data@doseGrid,
            model = DLEmodel
          ),
          efficacy(
            dose = data@doseGrid,
            model = Effmodel
          ),
          gain(
            dose = data@doseGrid,
            model_dle = DLEmodel,
            model_eff = Effmodel
          )
        )
      )
      gdata <- with(
        plotData,
        data.frame(
          x = dose,
          y = values,
          group = c(
            rep("p(DLE)", length(data@doseGrid)),
            rep("Expected Efficacy", length(data@doseGrid)),
            rep("Gain", length(data@doseGrid))
          ),
          colour = rep(c("blue", "green3", "red")),
          Type = factor("Estimate", levels = "Estimate")
        )
      )

      # if changing the line type is unacceptable, consider
      # https://stackoverflow.com/questions/25632242/filled-and-hollow-shapes-where-the-fill-color-the-line-color
      plot1 <- ggplot(data = gdata, aes(x = x, y = y)) +
        geom_line(aes(group = group, linetype = group, colour = group), linewidth = 1) +
        scale_colour_manual(
          name = "Curves",
          values = c("blue", "green3", "red")
        ) +
        scale_linetype_manual(
          name = "Curves",
          values = c("solid", "dotted", "dashed")
        ) +
        xlab("Dose Level") +
        ylab(paste("Values"))

      TD30 <- dose(x = 0.3, model = DLEmodel)

      Gainfun <- function(DOSE) {
        -gain(DOSE, model_dle = DLEmodel, model_eff = Effmodel)
      }
      Gstar <- (
        optim(
          min(data@doseGrid),
          Gainfun,
          method = "L-BFGS-B",
          lower = min(data@doseGrid),
          upper = max(data@doseGrid)
        )$par
      )
      MaxGain <- -(
        optim(
          min(data@doseGrid),
          Gainfun,
          method = "L-BFGS-B",
          lower = min(data@doseGrid),
          upper = max(data@doseGrid)
        )$value
      )

      if ((TD30 < min(data@doseGrid)) | (TD30 > max(data@doseGrid))) {
        plot1 <- plot1
        message(paste("TD30", paste(TD30, " not within dose Grid")))
      } else {
        plot1 <- plot1 +
          geom_point(
            data = data.frame(x = TD30, y = 0.3),
            aes(x = x, y = y),
            colour = "violet",
            shape = 16,
            size = 8
          ) +
          annotate(
            "text",
            label = "p(DLE=0.3)",
            x = TD30 + 1,
            y = 0.2,
            size = 5,
            colour = "violet"
          )
      }

      # Add annotated point estimates to graph
      point_data <- tibble::tibble(
        Text = NA_character_,
        X = NA_real_,
        Y = NA_real_,
        Shape = NA_real_,
        Size = NA_real_,
        Colour = NA_character_,
        .rows = 0
      )

      if ((TD30 < min(data@doseGrid)) | (TD30 > max(data@doseGrid))) {
        message(paste("TD30", paste(TD30, " not within dose Grid")))
      } else {
        point_data <- point_data %>%
          tibble::add_row(
            X = TD30,
            Y = 0.3,
            Shape = shape[1],
            Size = size[1],
            Colour = "violet",
            Text = "p(DLE=0.3)"
          )
      }
      if ((Gstar < min(data@doseGrid)) | (Gstar > max(data@doseGrid))) {
        print(paste("Gstar=", paste(Gstar, " not within dose Grid")))
      } else {
        plot1 <- plot1 +
          geom_point(
            data = data.frame(x = Gstar, y = MaxGain),
            aes(x = x, y = y),
            colour = "green3",
            shape = 17,
            size = 8
          ) +
          annotate(
            "text",
            label = "Max Gain",
            x = Gstar,
            y = MaxGain - 0.1,
            size = 5,
            colour = "green3"
          )
      }
      point_data <- point_data %>%
        tibble::add_row(
          X = Gstar,
          Y = MaxGain,
          Shape = shape[2],
          Size = size[2],
          Colour = "green3",
          Text = "Max Gain"
        )


      plot1 <- plot1 +
        geom_point(
          data = point_data,
          inherit.aes = FALSE,
          aes(
            x = .data$X,
            y = .data$Y,
            shape = as.factor(.data$Shape),
            fill = .data$Colour
          ),
          colour = point_data$Colour,
          size = point_data$Size,
        ) +
        scale_fill_manual(
          name = "Estimates",
          labels = c("p(DLE = 0.3)", "Max Gain"),
          values = point_data$Colour
        ) +
        scale_shape_discrete(
          name = "Estimates",
          labels = c("p(DLE = 0.3)", "Max Gain"),
          breaks = point_data$Shape
        ) +
        guides(
          shape = guide_legend(override.aes = list(color = c("violet", "green3")))
        ) +
        coord_cartesian(
          xlim = c(0, max(data@doseGrid)),
          ylim = c(min(gdata$y), max(gdata$y))
        )
      return(plot1)
    }
)
## ==========================================================================================

## -------------------------------------------------------------------------------
## Plot of the DLE and efficacy curve sides by side with samples
## -----------------------------------------------------------------------------
#' Plot of the DLE and efficacy curve side by side given a DLE pseudo model,
#' a DLE sample, an efficacy pseudo model and a given efficacy sample
#'
#' @param DLEmodel the pseudo DLE model of \code{\linkS4class{ModelTox}} class object
#' @param DLEsamples the DLE samples of \code{\linkS4class{Samples}} class object
#' @param Effmodel the pseudo efficacy model of \code{\linkS4class{ModelEff}} class object
#' @param Effsamples the Efficacy samples of \code{\linkS4class{Samples}} class object
#' @param data the data input of \code{\linkS4class{DataDual}} class object
#' @param extrapolate should the biomarker fit be extrapolated to the whole
#' dose grid? (default)
#' @param showLegend should the legend be shown? (not default)
#' @param \dots additional arguments for the parent method
#' \code{\link{plot,Samples,GeneralModel-method}}
#' @return This returns the \code{\link[ggplot2]{ggplot}}
#' object with the dose-toxicity and dose-efficacy model fits
#'
#' @example examples/Samples-method-plotDualResponses.R
#'
#' @export
#' @keywords methods
setGeneric("plotDualResponses",
  def =
    function(DLEmodel,
             DLEsamples,
             Effmodel,
             Effsamples,
             data, ...) {
      standardGeneric("plotDualResponses")
    }
)

#' @describeIn plotDualResponses function still to be documented
setMethod("plotDualResponses",
  signature =
    signature(
      DLEmodel = "ModelTox",
      DLEsamples = "Samples",
      Effmodel = "ModelEff",
      Effsamples = "Samples"
    ),
  def =
    function(DLEmodel, DLEsamples, Effmodel, Effsamples, data, extrapolate = TRUE, showLegend = FALSE, ...) {
      assert_logical(extrapolate)
      assert_logical(showLegend)
      ## Get Toxicity plot
      ## get the fit

      plotDLEData <- fit(DLEsamples,
        model = DLEmodel,
        data = data,
        quantiles = c(0.025, 0.975),
        middle = mean
      )

      ## make the plot
      gdata <-
        with(
          plotDLEData,
          data.frame(
            x = rep(dose, 3),
            y = c(middle, lower, upper) * 100,
            group =
              rep(c("mean", "lower", "upper"),
                each = nrow(plotDLEData)
              ),
            Type =
              factor(
                c(
                  rep(
                    "Estimate",
                    nrow(plotDLEData)
                  ),
                  rep(
                    "95% Credible Interval",
                    nrow(plotDLEData) * 2
                  )
                ),
                levels =
                  c(
                    "Estimate",
                    "95% Credible Interval"
                  )
              )
          )
        )

      ret1 <- gdata %>% ggplot() +
        geom_line(
          aes(
            x = x,
            y = y,
            group = group,
            linetype = Type
          ),
          colour = I("red"),
        ) +
        labs(
          x = "Dose Levels",
          y = "Probability of DLE [%]"
        ) +
        coord_cartesian(ylim = c(0, 100)) +
        scale_linetype_manual(
          breaks = c(
            "Estimate",
            "95% Credible Interval"
          ),
          values = c(1, 2),
          guide = ifelse(showLegend, "legend", "none")
        )
      ## only look at these dose levels for the plot:

      xLevels <- if (extrapolate) {
        seq_along(data@doseGrid)
      } else {
        1:max(data@xLevel)
      }

      ## get the plot data for the efficacy
      functionSamples <- matrix(
        nrow = size(Effsamples),
        ncol = length(xLevels)
      )
      ## evaluate the efficacy for all samples
      for (i in seq_along(xLevels)) {
        ## Now we want to evaluate for the following dose
        functionSamples[, i] <- efficacy(
          dose = data@doseGrid[xLevels[i]],
          model = Effmodel,
          samples = Effsamples
        )
      }
      ## extract mean curve
      meanCurve <- colMeans(functionSamples)

      ## extract quantiles
      quantiles <- c(0.025, 0.975)
      quantCurve <- apply(functionSamples, 2L, quantile, prob = quantiles)

      ## now create the data frame
      plotEffData <- data.frame(
        dose = data@doseGrid[xLevels],
        mean = meanCurve,
        lower = quantCurve[1, ],
        upper = quantCurve[2, ]
      )
      ## make the second plot
      ggdata <- with(plotEffData, data.frame(
        x = rep(dose, 3),
        y = c(mean, lower, upper),
        group =
          rep(c("mean", "lower", "upper"),
            each = nrow(plotEffData)
          ),
        Type =
          factor(
            c(
              rep(
                "Estimate",
                nrow(plotEffData)
              ),
              rep(
                "95% Credible Interval",
                nrow(plotEffData) * 2
              )
            ),
            levels =
              c(
                "Estimate",
                "95% Credible Interval"
              )
          )
      ))

      plot2 <- ggdata %>% ggplot() +
        geom_line(
          aes(
            x = x,
            y = y,
            group = group,
            linetype = Type
          ),
          colour = I("blue"),
        ) +
        labs(
          x = "Dose level",
          y = "Expected Efficacy"
        ) +
        scale_linetype_manual(
          breaks =
            c(
              "Estimate",
              "95% Credible Interval"
            ),
          values = c(1, 2),
          guide = ifelse(showLegend, "legend", "none")
        )

      ## arrange both plots side by side
      ret <- gridExtra::arrangeGrob(ret1, plot2, ncol = 2)
      return(ret)
    }
)

## ------------------------------------------------------------------------------
## Plot of the DLE and efficacy curve sides by side without  samples
## -----------------------------------------------------------------------------
#' Plot of the dose-DLE and dose-efficacy curve side by side given a DLE pseudo model
#' and a given pseudo efficacy model without DLE and efficacy samples
#'
#' @describeIn plotDualResponses Plot the DLE and efficacy curve side by side given a DLE model
#' and an efficacy model without any samples
#'
#' @example examples/Samples-method-plotDualResponsesNoSamples.R
#'
#' @export
#' @keywords methods
setMethod("plotDualResponses",
  signature =
    signature(
      DLEmodel = "ModelTox",
      DLEsamples = "missing",
      Effmodel = "ModelEff",
      Effsamples = "missing"
    ),
  def =
    function(DLEmodel, Effmodel, data, ...) {
      ## Get Toxicity plot
      ## get the fit


      ## Make sure the model estimates are corresponds to the input data
      DLEmodel <- update(object = DLEmodel, data = data)
      Effmodel <- update(object = Effmodel, data = data)


      plotDLEData <- data.frame(
        dose = data@doseGrid,
        probDLE = prob(
          dose = data@doseGrid,
          model = DLEmodel
        )
      )
      ## make the plot
      gdata <- with(
        plotDLEData,
        data.frame(
          x = dose,
          y = probDLE,
          group = rep("Estimated DLE", each = nrow(plotDLEData)),
          Type = factor(rep("Estimated DLE", nrow(plotDLEData)), levels = "Estimated DLE")
        )
      )

      plot1 <- ggplot(data = gdata, aes(x = x, y = y), group = group) +
        xlab("Dose Levels") +
        ylab(paste("Probability of DLE")) +
        ylim(c(0, 1)) +
        xlim(c(0, max(data@doseGrid))) +
        geom_line(colour = I("red"), linewidth = 1.5)


      plot1 <- plot1 +
        geom_line(linewidth = 1.5, colour = "red")

      ## only look at these dose levels for the plot:

      ## get the plot data for the efficacy
      plotEffData <- data.frame(
        dose = data@doseGrid,
        ExpEff = efficacy(
          dose = data@doseGrid,
          model = Effmodel
        )
      )

      ## make the second plot
      ggdata <- with(
        plotEffData,
        data.frame(
          x = dose,
          y = ExpEff,
          group = rep("Estimated Expected Efficacy", each = nrow(plotEffData)),
          Type = factor(rep("Estimated Expected Efficacy", nrow(plotEffData)), levels = "Estimated Expected Efficacy")
        )
      )

      ## Get efficacy plot
      plot2 <- ggplot(data = ggdata, aes(x = x, y = y), group = group) +
        xlab("Dose Levels") +
        ylab(paste("Estimatimated Expected Efficacy")) +
        xlim(c(0, max(data@doseGrid))) +
        geom_line(colour = I("blue"), linewidth = 1.5)

      plot2 <- plot2 +
        geom_line(linewidth = 1.5, colour = "blue")

      ## arrange both plots side by side
      ret <- gridExtra::arrangeGrob(plot1, plot2, ncol = 2)
      return(ret)
    }
)
## =======================================================================================================

## ----------------------------------------------------------------
## Get fitted DLT free survival (piecewise exponential model) based on
## the DA-CRM model
## -----------------------------------------------------------------
#' Get the fitted DLT free survival (piecewise exponential model).
#' This function returns a data frame with dose, middle, lower and upper
#' quantiles for the `PEM` curve. If hazard=TRUE,
#' @param object mcmc samples
#' @param model the mDA-CRM model
#' @param data the data input, a \code{\linkS4class{DataDA}} class object
#' @param quantiles the quantiles to be calculated (default: 0.025 and
#' 0.975)
#' @param middle the function for computing the middle point. Default:
#' \code{\link{mean}}
#' @param hazard should the the hazard over time be plotted based on the `PEM`? (not default)
#'   Otherwise ...
#' @param \dots additional arguments for methods
#'
#' @export
#' @keywords methods
setGeneric("fitPEM",
  def =
    function(object,
             model,
             data,
             quantiles = c(0.025, 0.975),
             middle = mean,
             hazard = FALSE,
             ...) {
      ## there should be no default method,
      ## therefore just forward to next method!
      standardGeneric("fitPEM")
    },
  valueClass = "data.frame"
)


#' Likelihood of DLTs in each interval
#'
#' This is a helper function for the `fitPEM` methods below.
#'
#' @param lambda the vector of piecewise hazards
#' @param Tmax the end of the time interval for DLTs
#' @return vector with the probabilities for DLTs within the intervals.
#'
#' @keywords internal
DLTLikelihood <- function(lambda,
                          Tmax) {
  npiece <- length(lambda)
  h <- seq(from = 0L, to = Tmax, length = npiece + 1)

  # Length of each time interval;
  sT <- rep(0, npiece)


  for (i in 1:npiece) {
    sT[i] <- h[i + 1] - h[i]
  }


  # calculate the exponential part of the distribution:
  s_ij <- function(t, j) {
    if (t > h[j]) {
      min(t - h[j], h[j + 1] - h[j])
    } else {
      0
    }
  }


  # The cumulative hazard function
  expNmu <- function(t) {
    ret <- 1
    for (j in 1:npiece) {
      ret <- ret * exp(-lambda[j] * s_ij(t, j))
    }
    return(ret)
  }

  # CDF of the piecewise exponential
  piece_exp_cdf <- function(x) {
    1 - expNmu(x)
  }

  DLTFreeS <- function(x) {
    (expNmu(x) - expNmu(Tmax)) / piece_exp_cdf(Tmax)
  }

  pDLT <- rep(0, npiece + 1)

  for (i in 1:(npiece)) {
    pDLT[i] <- DLTFreeS(h[i]) - DLTFreeS(h[i + 1])
  }

  return(pDLT)
}

## --------------------------------------------------------------------
## Get fitted DLT free survival (piecewise exponential model) based on
## the DA-CRM model
## -------------------------------------------------------------
#' @describeIn fitPEM This method works for the \code{\linkS4class{DALogisticLogNormal}}
#' model class.
#' @example examples/Samples-method-fitPEM-DALogisticLogNormal.R
setMethod("fitPEM",
  signature =
    signature(
      object = "Samples",
      model = "DALogisticLogNormal",
      data = "DataDA"
    ),
  def =
    function(object,
             model,
             data,
             quantiles = c(0.025, 0.975),
             middle = mean,
             hazard = FALSE,
             ...) {
      ## some checks
      assert_probability_range(quantiles)
      assert_logical(hazard)
      ## Plot points
      points <- seq(0, data@Tmax, length = model@npiece + 1)
      ## first we have to get samples from the PEM
      ## at intercept points and 2 middel points between
      ## intercepts.
      PEMSamples <- matrix(
        nrow = size(object),
        ncol = length(points)
      )

      i_max <- max(seq_along(points))
      ## evaluate the probs, for all samples.

      # The PEM
      if (hazard == FALSE) {
        PEMSamples <- t(apply(object@data$lambda, 1, function(x) {
          fit <- DLTLikelihood(x, data@Tmax)
          return(fit)
        }))
      } else if (hazard == TRUE) {
        for (i in seq_along(points)) {
          if (i == i_max) {
            PEMSamples[, i_max] <- object@data$lambda[, model@npiece]
          } else {
            PEMSamples[, i] <- object@data$lambda[, i]
          }
        }
      }

      ## extract middle curve
      middleCurve <- apply(PEMSamples, 2L, FUN = middle)

      ## extract quantiles
      quantCurve <- apply(PEMSamples, 2L, quantile,
        prob = quantiles
      )

      ## now create the data frame
      ret <- data.frame(
        time = points,
        middle = middleCurve,
        lower = quantCurve[1, ],
        upper = quantCurve[2, ]
      )

      ## return it
      return(ret)
    }
)

## =======================================================================================================


## --------------------------------------------------
## Plot survival curve fit over time
## --------------------------------------------------

## todo: add example file
#' Plotting dose-toxicity model fits
#'
#' @param x the \code{\linkS4class{Samples}} object
#' @param y the \code{\linkS4class{DALogisticLogNormal}} object
#' @param data the \code{\linkS4class{DataDA}} object
#' @param hazard see \code{\link{fitPEM}} for the explanation
#' @param \dots not used
#' @param showLegend should the legend be shown? (default)
#' @return This returns the \code{\link[ggplot2]{ggplot}}
#' object for the dose-toxicity model fit
#'
#' @export
setMethod("plot",
  signature =
    signature(
      x = "Samples",
      y = "DALogisticLogNormal"
    ),
  def =
    function(x, y, data, hazard = FALSE, ...,
             showLegend = TRUE) {
      ## check args
      assert_logical(showLegend)
      assert_logical(hazard)

      ## call the superclass method, to get the toxicity plot
      plot1 <- callNextMethod(x, y, data, showLegend = showLegend, ...)

      ## get the fit
      fitData <- fitPEM(x,
        model = y,
        data = data,
        quantiles = c(0.025, 0.975),
        middle = mean,
        hazard = hazard
      )

      ## make the plot
      Tpoints <- seq(0, data@Tmax, length = y@npiece + 1)
      plotData <-
        with(
          fitData,
          data.frame(
            x = rep(Tpoints, 3),
            y = c(middle, lower, upper) * 100,
            group =
              rep(c("mean", "lower", "upper"),
                each = nrow(fitData)
              ),
            Type =
              factor(
                c(
                  rep(
                    "Estimate",
                    nrow(fitData)
                  ),
                  rep(
                    "95% Credible Interval",
                    nrow(fitData) * 2
                  )
                ),
                levels =
                  c(
                    "Estimate",
                    "95% Credible Interval"
                  )
              )
          )
        )
      plot2 <- plotData %>% ggplot() +
        geom_step(
          aes(
            x = x,
            y = y,
            group = group,
            linetype = Type
          ),
          colour = I("blue")
        ) +
        labs(
          x = "Time",
          y = if (hazard) "Hazard rate*100" else "Probability of DLT [%]"
        ) +
        coord_cartesian(
          ylim = if (hazard) range(plotData$y) else c(0, 100)
        )

      ret <- gridExtra::arrangeGrob(plot1, plot2, ncol = 2)
      return(ret)
    }
)


## =======================================================================================================

# tidy ----

## Samples

## tidy-Samples ----

#' @rdname tidy
#' @aliases tidy-Samples
#' @example examples/Samples-method-tidy.R
#' @export
setMethod(
  f = "tidy",
  signature = signature(x = "Samples"),
  definition = function(x, ...) {
    rv <- lapply(
      slotNames(x),
      function(nm) {
        if (nm == "data") {
          lapply(
            names(x@data),
            function(nm) {
              as_tibble(get(x, nm))
            }
          ) %>%
            dplyr::bind_rows() %>%
            tidyr::pivot_wider(
              names_from = Parameter,
              values_from = value
            ) %>%
            dplyr::bind_cols(h_handle_attributes(get(x, names(x@data)[1])))
        } else {
          slot(x, nm) %>%
            tidy() %>%
            dplyr::bind_cols()
        }
      }
    )
    names(rv) <- c("data", "options")
    rv <- rv %>% h_tidy_class(x)
    rv
  }
)

#' @include Design-validity.R
#' @include Model-class.R
#' @include Rules-class.R
#' @include Data-class.R
#' @include helpers.R
#' @include CrmPackClass-class.R
NULL

# RuleDesign ----

## class ----

#' `RuleDesign`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`RuleDesign`] is the class for rule-based designs. The difference between
#' this class and the [`Design`] class is that [`RuleDesign`] does not contain
#' `model`, `stopping` and `increments` slots.
#'
#' @slot nextBest (`NextBest`)\cr how to find the next best dose.
#' @slot cohort_size (`CohortSize`)\cr rules for the cohort sizes.
#' @slot data (`Data`)\cr specifies dose grid, any previous data, etc.
#' @slot startingDose (`number`)\cr the starting dose, it must lie on the dose
#'   grid in `data`.
#'
#' @aliases RuleDesign
#' @export
#'
.RuleDesign <- setClass(
  Class = "RuleDesign",
  slots = c(
    nextBest = "NextBest",
    cohort_size = "CohortSize",
    data = "Data",
    startingDose = "numeric"
  ),
  prototype = prototype(
    nextBest = .NextBestThreePlusThree(),
    cohort_size = CohortSizeConst(3),
    data = Data(doseGrid = 1:3),
    startingDose = 1
  ),
  contains = "CrmPackClass",
  validity = v_rule_design
)

## constructor ----

#' @rdname RuleDesign-class
#'
#' @param nextBest (`NextBest`)\cr see slot definition.
#' @param cohort_size (`CohortSize`)\cr see slot definition.
#' @param data (`Data`)\cr see slot definition.
#' @param startingDose (`number`)\cr see slot definition.
#'
#' @export
#' @example examples/Design-class-RuleDesign.R
#'
RuleDesign <- function(nextBest,
                       cohort_size,
                       data,
                       startingDose) {
  new(
    "RuleDesign",
    nextBest = nextBest,
    cohort_size = cohort_size,
    data = data,
    startingDose = as.numeric(startingDose)
  )
}

#' @rdname RuleDesign-class
#' @note Typically, end users will not use the `.DefaultRuleDesign()` function.
#' @export

.DefaultRuleDesign <- function() {
  RuleDesign(
    nextBest = NextBestThreePlusThree(),
    cohort_size = CohortSizeConst(size = 3L),
    data = Data(doseGrid = c(5, 10, 15, 25, 35, 50, 80)),
    startingDose = 5
  )
}

## ThreePlusThreeDesign ----

#' @describeIn RuleDesign-class creates a new 3+3 design object from a dose grid.
#'
#' @param doseGrid (`numeric`)\cr the dose grid to be used (sorted).
#'
#' @export
#' @example examples/Design-class-ThreePlusThreeDesign.R
#'
ThreePlusThreeDesign <- function(doseGrid) {
  empty_data <- Data(doseGrid = doseGrid)

  # Using a constant cohort size of 3 we obtain exactly the 3+3 design.
  RuleDesign(
    nextBest = NextBestThreePlusThree(),
    data = empty_data,
    cohort_size = CohortSizeConst(size = 3L),
    startingDose = doseGrid[1]
  )
}

# Design ----

## class ----

#' `Design`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`Design`] is the class for rule-based designs. The difference between
#' this class and its parent [`RuleDesign`] class is that [`Design`] class
#' contains additional `model`, `stopping` and `increments` slots.
#'
#' @slot model (`GeneralModel`)\cr the model to be used.
#' @slot stopping (`Stopping`)\cr stopping rule(s) for the trial.
#' @slot increments (`Increments`)\cr how to control increments between dose levels.
#' @slot pl_cohort_size (`CohortSize`)\cr rules for the cohort sizes for placebo,
#'   if any planned (defaults to constant 0 placebo patients).
#'
#' @aliases Design
#' @export
#'
.Design <- setClass(
  Class = "Design",
  slots = c(
    model = "GeneralModel",
    stopping = "Stopping",
    increments = "Increments",
    pl_cohort_size = "CohortSize"
  ),
  prototype = prototype(
    model = .LogisticNormal(),
    nextBest = .NextBestNCRM(),
    stopping = .StoppingMinPatients(),
    increments = .IncrementsRelative(),
    pl_cohort_size = CohortSizeConst(0L)
  ),
  contains = "RuleDesign"
)

## constructor ----

#' @rdname Design-class
#'
#' @param model (`GeneralModel`)\cr see slot definition.
#' @param stopping (`Stopping`)\cr see slot definition.
#' @param increments (`Increments`)\cr see slot definition.
#' @param pl_cohort_size (`CohortSize`)\cr see slot definition.
#' @inheritDotParams RuleDesign
#'
#' @export
#' @example examples/Design-class-Design.R
#'
#'
Design <- function(model,
                   stopping,
                   increments,
                   pl_cohort_size = CohortSizeConst(0L),
                   ...) {
  start <- RuleDesign(...)
  new(
    "Design",
    start,
    model = model,
    stopping = stopping,
    increments = increments,
    pl_cohort_size = pl_cohort_size
  )
}

## default constructor ----

#' @rdname Design-class
#' @note Typically, end users will not use the `.DefaultDesign()` function.
#' @export
.DefaultDesign <- function() {
  my_size1 <- CohortSizeRange(
    intervals = c(0, 30),
    cohort_size = c(1, 3)
  )
  my_size2 <- CohortSizeDLT(
    intervals = c(0, 1),
    cohort_size = c(1, 3)
  )
  my_size <- maxSize(my_size1, my_size2)

  my_stopping1 <- StoppingMinCohorts(nCohorts = 3)
  my_stopping2 <- StoppingTargetProb(
    target = c(0.2, 0.35),
    prob = 0.5
  )
  my_stopping3 <- StoppingMinPatients(nPatients = 20)
  my_stopping <- (my_stopping1 & my_stopping2) | my_stopping3

  # Initialize the design.
  design <- Design(
    model = LogisticLogNormal(
      mean = c(-0.85, 1),
      cov = matrix(c(1, -0.5, -0.5, 1), nrow = 2),
      ref_dose = 56
    ),
    nextBest = NextBestNCRM(
      target = c(0.2, 0.35),
      overdose = c(0.35, 1),
      max_overdose_prob = 0.25
    ),
    stopping = my_stopping,
    increments = IncrementsRelative(
      intervals = c(0, 20),
      increments = c(1, 0.33)
    ),
    cohort_size = my_size,
    data = Data(doseGrid = c(1, 3, 5, 10, 15, 20, 25, 40, 50, 80, 100)),
    startingDose = 3
  )
}

# DualDesign ----

## class ----

#' `DualDesign`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`DualDesign`] is the class for the dual-endpoint CRM design. This class has
#' special requirements for the `model` and `data` slots in comparison to the
#' parent class [`Design`].
#'
#' @note the `nextBest` slot can be of any class, this allows for easy comparison
#'   with recommendation methods that don't use the biomarker information.
#'
#' @slot model (`DualEndpoint`)\cr the model to be used.
#' @slot data (`DataDual`)\cr specifies dose grid, any previous data, etc.
#'
#' @aliases DualDesign
#' @export
#'
.DualDesign <- setClass(
  Class = "DualDesign",
  slots = c(
    model = "DualEndpoint",
    data = "DataDual"
  ),
  prototype = prototype(
    model = .DualEndpoint(),
    nextBest = .NextBestDualEndpoint(),
    data = DataDual(doseGrid = 1:2),
    startingDose = 1
  ),
  contains = "Design"
)

## constructor ----

#' @rdname DualDesign-class
#'
#' @param model (`DualEndpoint`)\cr see slot definition.
#' @param data (`DataDual`)\cr see slot definition.
#' @inheritDotParams Design
#'
#' @export
#' @example examples/Design-class-DualDesign.R
#'
DualDesign <- function(model,
                       data,
                       ...) {
  start <- Design(model = model, data = data, ...)
  new(
    "DualDesign",
    start,
    model = model,
    data = data
  )
}

## default constructor ----

#' @rdname DualDesign-class
#' @note Typically, end users will not use the `.DefaultDualDesign()` function.
#' @export
.DefaultDualDesign <- function() {
  my_model <- DualEndpointRW(
    mean = c(0, 1),
    cov = matrix(c(1, 0, 0, 1), nrow = 2),
    sigma2betaW = 0.01,
    sigma2W = c(a = 0.1, b = 0.1),
    rho = c(a = 1, b = 1),
    rw1 = TRUE
  )

  # Choose the rule for selecting the next dose.
  my_next_best <- NextBestDualEndpoint(
    target = c(0.9, 1),
    overdose = c(0.35, 1),
    max_overdose_prob = 0.25
  )

  # Choose the rule for the cohort-size.
  my_size1 <- CohortSizeRange(
    intervals = c(0, 30),
    cohort_size = c(1, 3)
  )
  my_size2 <- CohortSizeDLT(
    intervals = c(0, 1),
    cohort_size = c(1, 3)
  )
  my_size <- maxSize(my_size1, my_size2)

  # Choose the rule for stopping.
  my_stopping1 <- StoppingTargetBiomarker(
    target = c(0.9, 1),
    prob = 0.5
  )
  my_stopping <- my_stopping1 | StoppingMinPatients(40)

  # Choose the rule for dose increments.
  my_increments <- IncrementsRelative(
    intervals = c(0, 20),
    increments = c(1, 0.33)
  )

  # Initialize the design.
  DualDesign(
    model = my_model,
    data = DataDual(doseGrid = c(1, 3, 5, 10, 15, 20, 25, 40, 50, 80, 100)),
    nextBest = my_next_best,
    stopping = my_stopping,
    increments = my_increments,
    cohort_size = my_size,
    startingDose = 3
  )
}

# TDsamplesDesign ----

## class ----

#' `TDsamplesDesign`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`TDsamplesDesign`] is the class of design based only on DLT responses using
#' [`ModelTox`] class model (i.e. [`LogisticIndepBeta`]) as well as MCMC samples
#' obtained for this model.
#'
#' @slot model (`ModelTox`)\cr the pseudo DLT model to be used.
#' @slot stopping (`Stopping`)\cr stopping rule(s) for the trial.
#' @slot increments (`Increments`)\cr how to control increments between dose levels.
#' @slot pl_cohort_size (`CohortSize`)\cr rules for the cohort sizes for placebo,
#'   if any planned (defaults to constant 0 placebo patients).
#'
#' @aliases TDsamplesDesign
#' @export
#'
.TDsamplesDesign <- setClass(
  Class = "TDsamplesDesign",
  slots = c(
    model = "ModelTox",
    stopping = "Stopping",
    increments = "Increments",
    pl_cohort_size = "CohortSize"
  ),
  prototype = prototype(
    model = .LogisticIndepBeta(),
    nextBest = .NextBestTDsamples(),
    stopping = .StoppingMinPatients(),
    increments = .IncrementsRelative(),
    pl_cohort_size = CohortSizeConst(0L)
  ),
  contains = "RuleDesign"
)

## constructor ----

#' @rdname TDsamplesDesign-class
#'
#' @param model (`ModelTox`)\cr see slot definition.
#' @param stopping (`Stopping`)\cr see slot definition.
#' @param increments (`Increments`)\cr see slot definition.
#' @param pl_cohort_size (`CohortSize`)\cr see slot definition.
#' @inheritDotParams RuleDesign
#'
#' @export
#' @example examples/Design-class-TDsamplesDesign.R
#'
TDsamplesDesign <- function(model,
                            stopping,
                            increments,
                            pl_cohort_size = CohortSizeConst(0L),
                            ...) {
  start <- RuleDesign(...)
  new(
    "TDsamplesDesign",
    start,
    model = model,
    stopping = stopping,
    increments = increments,
    pl_cohort_size = pl_cohort_size
  )
}

## default constructor ----

#' @rdname TDsamplesDesign-class
#' @note Typically, end users will not use the `.DefaultTDsamplesDesign()` function.
#' @export
.DefaultTDsamplesDesign <- function() {
  empty_data <- Data(doseGrid = seq(25, 300, 25))

  my_model <- LogisticIndepBeta(
    binDLE = c(1.05, 1.8),
    DLEweights = c(3, 3),
    DLEdose = c(25, 300),
    data = empty_data
  )

  TDsamplesDesign(
    model = my_model,
    stopping = StoppingMinPatients(nPatients = 36),
    increments = IncrementsRelative(
      intervals = range(empty_data@doseGrid),
      increments = c(2, 2)
    ),
    nextBest = NextBestTDsamples(
      prob_target_drt = 0.35,
      prob_target_eot = 0.3,
      derive = function(samples) {
        as.numeric(quantile(samples, probs = 0.3))
      }
    ),
    cohort_size = CohortSizeConst(size = 3),
    data = empty_data,
    startingDose = 25
  )
}

# TDDesign ----

## class ----

#' `TDDesign`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`TDDesign`] is the class of design based only on DLT responses using
#' [`ModelTox`] class model (i.e. [`LogisticIndepBeta`]) without MCMC samples.
#'
#' @slot model (`ModelTox`)\cr the pseudo DLT model to be used.
#' @slot stopping (`Stopping`)\cr stopping rule(s) for the trial.
#' @slot increments (`Increments`)\cr how to control increments between dose levels.
#' @slot pl_cohort_size (`CohortSize`)\cr rules for the cohort sizes for placebo,
#'   if any planned (defaults to constant 0 placebo patients).
#'
#' @aliases TDDesign
#' @export
#'
.TDDesign <- setClass(
  Class = "TDDesign",
  slots = c(
    model = "ModelTox",
    stopping = "Stopping",
    increments = "Increments",
    pl_cohort_size = "CohortSize"
  ),
  prototype = prototype(
    model = .LogisticIndepBeta(),
    nextBest = .NextBestTD(),
    stopping = .StoppingMinPatients(),
    increments = .IncrementsRelative(),
    pl_cohort_size = CohortSizeConst(0L)
  ),
  contains = "RuleDesign"
)

## constructor ----

#' @rdname TDDesign-class
#'
#' @param model (`ModelTox`)\cr see slot definition.
#' @param stopping (`Stopping`)\cr see slot definition.
#' @param increments (`Increments`)\cr see slot definition.
#' @param pl_cohort_size (`CohortSize`)\cr see slot definition.
#' @inheritDotParams RuleDesign
#'
#' @export
#' @example examples/Design-class-TDDesign.R
#'
TDDesign <- function(model,
                     stopping,
                     increments,
                     pl_cohort_size = CohortSizeConst(0L),
                     ...) {
  start <- RuleDesign(...)
  new(
    "TDDesign",
    start,
    model = model,
    stopping = stopping,
    increments = increments,
    pl_cohort_size = pl_cohort_size
  )
}

## default constructor ----

#' @rdname TDDesign-class
#' @note Typically, end users will not use the `.DefaultTDDesign()` function.
#' @export
.DefaultTDDesign <- function() {
  empty_data <- Data(doseGrid = seq(25, 300, 25))

  my_model <- LogisticIndepBeta(
    binDLE = c(1.05, 1.8),
    DLEweights = c(3, 3),
    DLEdose = c(25, 300),
    data = empty_data
  )

  TDDesign(
    model = my_model,
    stopping = StoppingMinPatients(nPatients = 36),
    increments = IncrementsRelative(
      intervals = range(empty_data@doseGrid),
      increments = c(2, 2)
    ),
    nextBest = NextBestTD(
      prob_target_drt = 0.35,
      prob_target_eot = 0.3
    ),
    cohort_size = CohortSizeConst(size = 3),
    data = empty_data,
    startingDose = 25
  )
}

# DualResponsesSamplesDesign ----

## class ----

#' `DualResponsesSamplesDesign`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' This is a class of design based on DLE responses using the [`LogisticIndepBeta`] model
#  and efficacy responses using [`ModelEff`]  model class
#' with DLE and efficacy samples. It contain all slots in
#' [`RuleDesign`] and [`TDsamplesDesign`] class objects.
#
#' @slot data (`DataDual`)\cr the data set.
#' @slot eff_model (`ModelEff`)\cr the pseudo efficacy model to be used.
#'
#' @aliases DualResponsesSamplesDesign
#' @export
#'
.DualResponsesSamplesDesign <-
  setClass(
    Class = "DualResponsesSamplesDesign",
    slots = c(
      eff_model = "ModelEff",
      data = "DataDual"
    ),
    prototype = prototype(
      nextBest = .NextBestMaxGainSamples(),
      data = DataDual(doseGrid = 1:2),
      startingDose = 1,
      model = .LogisticIndepBeta()
    ),
    contains = "TDsamplesDesign"
  )

## constructor ----

#' @rdname DualResponsesSamplesDesign-class
#'
#' @param data (`DataDual`)\cr see slot definition.
#' @param eff_model (`ModelEff`)\cr see slot definition.
#' @inheritDotParams TDsamplesDesign
#'
#' @example examples/Design-class-DualResponsesSamplesDesign.R
#' @export
#'
DualResponsesSamplesDesign <- function(eff_model,
                                       data,
                                       ...) {
  start <- TDsamplesDesign(data = data, ...)
  .DualResponsesSamplesDesign(
    start,
    eff_model = eff_model,
    data = data
  )
}

## default constructor ----

#' @rdname DualResponsesSamplesDesign-class
#' @note Typically, end users will not use the `.DefaultDualResponsesSamplesDesign()` function.
#' @export
.DefaultDualResponsesSamplesDesign <- function() {
  empty_data <- DataDual(doseGrid = seq(25, 300, 25))

  tox_model <- LogisticIndepBeta(
    binDLE = c(1.05, 1.8),
    DLEweights = c(3, 3),
    DLEdose = c(25, 300),
    data = empty_data
  )
  options <- McmcOptions(burnin = 100, step = 2, samples = 200)
  tox_samples <- mcmc(empty_data, tox_model, options)

  eff_model <- Effloglog(
    eff = c(1.223, 2.513),
    eff_dose = c(25, 300),
    nu = c(a = 1, b = 0.025),
    data = empty_data
  )
  eff_samples <- mcmc(empty_data, eff_model, options)

  my_next_best <- NextBestMaxGainSamples(
    prob_target_drt = 0.35,
    prob_target_eot = 0.3,
    derive = function(samples) {
      as.numeric(quantile(samples, prob = 0.3))
    },
    mg_derive = function(mg_samples) {
      as.numeric(quantile(mg_samples, prob = 0.5))
    }
  )

  DualResponsesSamplesDesign(
    nextBest = my_next_best,
    cohort_size = CohortSizeConst(size = 3),
    startingDose = 25,
    model = tox_model,
    eff_model = eff_model,
    data = empty_data,
    stopping = StoppingMinPatients(nPatients = 36),
    increments = IncrementsRelative(
      intervals = c(25, 300),
      increments = c(2, 2)
    )
  )
}

# DualResponsesDesign.R ----

## class ----

#' `DualResponsesDesign.R`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' This is a class of design based on DLE responses using the [`LogisticIndepBeta`] model
#  and efficacy responses using the [`ModelEff`]  model class
#' without DLE and efficacy samples. It contains all slots from the
#' [`RuleDesign`] and [`TDsamplesDesign`] classes.
#
#' @slot data (`DataDual`)\cr the data set.
#' @slot eff_model (`ModelEff`)\cr the pseudo efficacy model to be used.
#'
#' @aliases DualResponsesDesign
#' @export
#'
.DualResponsesDesign <-
  setClass(
    Class = "DualResponsesDesign",
    slots = c(
      eff_model = "ModelEff",
      data = "DataDual"
    ),
    prototype = prototype(
      nextBest = .NextBestMaxGain(),
      data = DataDual(doseGrid = 1:2),
      startingDose = 1,
      model = .LogisticIndepBeta()
    ),
    contains = "TDDesign"
  )

## constructor ----

#' @rdname DualResponsesDesign-class
#'
#' @param data (`DataDual`)\cr see slot definition.
#' @param eff_model (`ModelEff`)\cr see slot definition.
#' @inheritDotParams TDDesign
#'
#' @example examples/Design-class-DualResponsesDesign.R
#' @export
#'
DualResponsesDesign <- function(eff_model,
                                data,
                                ...) {
  start <- TDDesign(data = data, ...)
  .DualResponsesDesign(
    start,
    eff_model = eff_model,
    data = data
  )
}

## default constructor ----

#' @rdname DualResponsesDesign-class
#' @note Typically, end users will not use the `.DefaultDualResponsesDesign()` function.
#' @export
.DefaultDualResponsesDesign <- function() {
  empty_data <- DataDual(doseGrid = seq(25, 300, 25))

  DualResponsesDesign(
    nextBest = NextBestMaxGain(
      prob_target_drt = 0.35,
      prob_target_eot = 0.3
    ),
    cohort_size = CohortSizeConst(size = 3),
    startingDose = 25,
    model = LogisticIndepBeta(
      binDLE = c(1.05, 1.8),
      DLEweights = c(3, 3),
      DLEdose = c(25, 300),
      data = empty_data
    ),
    eff_model = Effloglog(
      eff = c(1.223, 2.513),
      eff_dose = c(25, 300),
      nu = c(a = 1, b = 0.025),
      data = empty_data
    ),
    data = empty_data,
    stopping = StoppingMinPatients(nPatients = 36),
    increments = IncrementsRelative(
      intervals = c(25, 300),
      increments = c(2, 2)
    )
  )
}


# DADesign ----

## class ----

#' `DADesign`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' This class has special requirements for the `model` and `data`
#' slots in comparison to the parent class [`Design`]:
#'
#' @slot model (`GeneralModel`)\cr the model to use, see in particular [`DALogisticLogNormal`] and
#' [`TITELogisticLogNormal`] which make use of the time-to-DLT data.
#' @slot data (`DataDA`)\cr what is the dose grid, any previous data, etc.
#' @slot safetyWindow (`SafetyWindow`)\cr the safety window to apply between cohorts.
#'
#' @details
#' The `safetyWindow` slot should be an instance of the `SafetyWindow` class.
#' It can be customized to specify the duration of the safety window for your trial.
#' The safety window represents the time period required to observe toxicity data
#' from the ongoing cohort before opening the next cohort.
#' Note that even after opening the next cohort,
#' further toxicity data will be collected and analyzed to make dose escalation decisions.
#'
#'
#' To specify a constant safety window, use the `SafetyWindowConst` constructor. For example:
#'
#' \code{mysafetywindow <- SafetyWindowConst(c(6, 2), 10, 20)}
#'
#' @seealso [`SafetyWindowConst`] for creating a constant safety window.
#'
#' @aliases DADesign
#' @export
#'
.DADesign <-
  setClass(
    Class = "DADesign",
    slots = c(
      model = "GeneralModel",
      data = "DataDA",
      safetyWindow = "SafetyWindow"
    ),
    prototype = prototype(
      model = .DALogisticLogNormal(),
      nextBest = .NextBestNCRM(),
      data = DataDA(doseGrid = 1:2),
      safetyWindow = .SafetyWindowConst()
    ),
    contains = "Design"
  )


## constructor ----

#' @rdname DADesign-class
#'
#' @param model (`GeneralModel`)\cr see slot definition.
#' @param data (`DataDA`)\cr see slot definition.
#' @param safetyWindow (`SafetyWindow`)\cr see slot definition.
#' @inheritDotParams Design
#'
#' @example examples/Design-class-DADesign.R
#' @export
#'
DADesign <- function(model, data,
                     safetyWindow,
                     ...) {
  start <- Design(
    data = data,
    model = model,
    ...
  )
  .DADesign(start,
    safetyWindow = safetyWindow
  )
}

## default constructor ----

#' @rdname DADesign-class
#' @note Typically, end users will not use the `.DefaultDADesign()` function.
#' @export
.DefaultDADesign <- function() {
  emptydata <- DataDA(
    doseGrid = c(0.1, 0.5, 1, 1.5, 3, 6, seq(from = 10, to = 80, by = 2)),
    Tmax = 60
  )

  npiece_ <- 10
  t_max_ <- 60

  lambda_prior <- function(k) {
    npiece_ / (t_max_ * (npiece_ - k + 0.5))
  }

  model <- DALogisticLogNormal(
    mean = c(-0.85, 1),
    cov = matrix(c(1, -0.5, -0.5, 1), nrow = 2),
    ref_dose = 56,
    npiece = npiece_,
    l = as.numeric(t(apply(as.matrix(c(1:npiece_), 1, npiece_), 2, lambda_prior))),
    c_par = 2
  )

  mySize1 <- CohortSizeRange(
    intervals = c(0, 30),
    cohort_size = c(1, 3)
  )
  mySize2 <- CohortSizeDLT(
    intervals = c(0, 1),
    cohort_size = c(1, 3)
  )
  mySize <- maxSize(mySize1, mySize2)

  myStopping1 <- StoppingTargetProb(
    target = c(0.2, 0.35),
    prob = 0.5
  )
  myStopping2 <- StoppingMinPatients(nPatients = 50)
  myStopping <- (myStopping1 | myStopping2)

  DADesign(
    model = model,
    increments = IncrementsRelative(
      intervals = c(0, 20),
      increments = c(1, 0.33)
    ),
    nextBest = NextBestNCRM(
      target = c(0.2, 0.35),
      overdose = c(0.35, 1),
      max_overdose_prob = 0.25
    ),
    stopping = myStopping,
    cohort_size = mySize,
    data = emptydata,
    safetyWindow = SafetyWindowConst(c(6, 2), 7, 7),
    startingDose = 3
  )
}
# DesignGrouped ----

## class ----

#' `DesignGrouped`
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' [`DesignGrouped`] combines two [`Design`] objects: one for the mono and one
#' for the combo arm of a joint dose escalation design.
#'
#' @slot model (`LogisticLogNormalGrouped`)\cr the model to be used, currently only one
#'   class is allowed.
#' @slot mono (`Design`)\cr defines the dose escalation rules for the mono arm, see
#'   details.
#' @slot combo (`Design`)\cr defines the dose escalation rules for the combo arm, see
#'   details.
#' @slot first_cohort_mono_only (`flag`)\cr whether first test one mono agent cohort, and then
#'   once its DLT data has been collected, we proceed from the second cohort onwards with
#'   concurrent mono and combo cohorts.
#' @slot same_dose_for_all (`flag`)\cr whether the lower dose of the separately determined mono and combo
#'   doses should be used as the next dose for both mono and combo in all cohorts.
#' @slot same_dose_for_start (`flag`)\cr indicates whether, when mono and combo are
#'   used in the same cohort for the first time, the same dose should be used for both.
#'   Note that this is different from `same_dose_for_all` which will always force
#'   them to be the same. If `same_dose_for_all = TRUE`, this is therefore ignored. See Details.
#' @slot stop_mono_with_combo (`flag`)\cr whether the mono arm should be stopped when the combo
#'   arm is stopped (this makes sense when the only real trial objective is the recommended combo dose).
#'
#' @details
#'
#'   - Note that the model slots inside the `mono` and `combo` parameters
#'     are ignored (because we don't fit separate regression models for the mono and
#'     combo arms). Instead, the `model` parameter is used to fit a joint regression
#'     model for the mono and combo arms together.
#'   - `same_dose_for_start = TRUE` is useful as an option when we want to use `same_dose_for_all = FALSE`
#'     combined with `first_cohort_mono_only = TRUE`.
#'     This will allow to randomize patients to the mono and combo arms at the same dose
#'     as long as the selected dose for the cohorts stay the same. This can therefore
#'     further mitigate bias as long as possible between the mono and combo arms.
#'
#' @aliases DesignGrouped
#' @export
#'
.DesignGrouped <- setClass(
  Class = "DesignGrouped",
  slots = c(
    model = "LogisticLogNormalGrouped",
    mono = "Design",
    combo = "Design",
    first_cohort_mono_only = "logical",
    same_dose_for_all = "logical",
    same_dose_for_start = "logical",
    stop_mono_with_combo = "logical"
  ),
  prototype = prototype(
    model = .DefaultLogisticLogNormalGrouped(),
    mono = .Design(),
    combo = .Design(),
    first_cohort_mono_only = TRUE,
    same_dose_for_all = TRUE,
    same_dose_for_start = FALSE,
    stop_mono_with_combo = FALSE
  ),
  validity = v_design_grouped,
  contains = "CrmPackClass"
)

## constructor ----

#' @rdname DesignGrouped-class
#'
#' @param model (`LogisticLogNormalGrouped`)\cr see slot definition.
#' @param mono (`Design`)\cr see slot definition.
#' @param combo (`Design`)\cr see slot definition.
#' @param first_cohort_mono_only (`flag`)\cr see slot definition.
#' @param same_dose_for_all (`flag`)\cr see slot definition.
#' @param same_dose_for_start (`flag`)\cr see slot definition.
#' @param stop_mono_with_combo (`flag`)\cr see slot definition.
#' @param ... not used.
#'
#' @export
#' @example examples/Design-class-DesignGrouped.R
#'
DesignGrouped <- function(model,
                          mono,
                          combo = mono,
                          first_cohort_mono_only = TRUE,
                          same_dose_for_all = !same_dose_for_start,
                          same_dose_for_start = FALSE,
                          stop_mono_with_combo = FALSE,
                          ...) {
  .DesignGrouped(
    model = model,
    mono = mono,
    combo = combo,
    first_cohort_mono_only = first_cohort_mono_only,
    same_dose_for_all = same_dose_for_all,
    same_dose_for_start = same_dose_for_start,
    stop_mono_with_combo = stop_mono_with_combo
  )
}

## default constructor ----

#' @rdname DesignGrouped-class
#' @note Typically, end-users will not use the `.DefaultDesignGrouped()` function.
#' @export
.DefaultDesignGrouped <- .DesignGrouped

# RuleDesignOrdinal ----

## class ----

#' `RuleDesignOrdinal`
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' [`RuleDesignOrdinal`] is the class for rule-based designs. The difference between
#' this class and the [`DesignOrdinal`] class is that [`RuleDesignOrdinal`]
#' does not contain `model`, `stopping` and `increments` slots.
#'
#' @slot next_best (`NextBestOrdinal`)\cr how to find the next best dose.
#' @slot cohort_size (`CohortSizeOrdinal`)\cr rules for the cohort sizes.
#' @slot data (`DataOrdinal`)\cr specifies dose grid, any previous data, etc.
#' @slot starting_dose (`number`)\cr the starting dose, it must lie on the dose
#'   grid in `data`.
#'
#' @aliases RuleDesignOrdinal
#' @export
#'
.RuleDesignOrdinal <- setClass(
  Class = "RuleDesignOrdinal",
  slots = c(
    next_best = "NextBestOrdinal",
    cohort_size = "CohortSizeOrdinal",
    data = "DataOrdinal",
    starting_dose = "numeric"
  ),
  prototype = prototype(
    next_best = .NextBestOrdinal(),
    cohort_size = CohortSizeOrdinal(1L, CohortSizeConst(3L)),
    data = DataOrdinal(doseGrid = 1:3),
    starting_dose = 1
  ),
  contains = "CrmPackClass",
  validity = v_rule_design_ordinal
)

## constructor ----

#' @rdname RuleDesignOrdinal-class
#'
#' @param next_best (`NextBestOrdinal`)\cr see slot definition.
#' @param cohort_size (`CohortSizeOrdinal`)\cr see slot definition.
#' @param data (`DataOrdinal`)\cr see slot definition.
#' @param starting_dose (`number`)\cr see slot definition.
#'
#' @export
#' @example examples/Design-class-RuleDesignOrdinal.R
#'
RuleDesignOrdinal <- function(
    next_best,
    cohort_size,
    data,
    starting_dose) {
  new(
    "RuleDesignOrdinal",
    next_best = next_best,
    cohort_size = cohort_size,
    data = data,
    starting_dose = as.numeric(starting_dose)
  )
}

#' @rdname RuleDesignOrdinal-class
#' @note Typically, end users will not use the `.DefaultRuleDesignOrdinal()` function.
#' @export

.DefaultRuleDesignOrdinal <- function() {
  RuleDesignOrdinal(
    next_best = NextBestOrdinal(
      1L,
      NextBestMTD(target = 0.25, derive = function(x) mean(x, na.rm = TRUE))
    ),
    cohort_size = CohortSizeOrdinal(1L, CohortSizeConst(size = 3L)),
    data = DataOrdinal(doseGrid = c(5, 10, 15, 25, 35, 50, 80)),
    starting_dose = 5
  )
}

# DesignOrdinal ----

## class ----

#' `DesignOrdinal`
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' [`DesignOrdinal`] is the class for rule-based ordinal designs. The difference
#' between this class and its parent [`RuleDesignOrdinal`] class is that the
#'  [`DesignOrdinal`] class contains additional `model`, `stopping`,
#'  `increments` and `pl_cohort_size` slots.
#'
#' @slot model (`LogisticLogNormalOrdinal`)\cr the model to be used.
#' @slot stopping (`StoppingOrdinal`)\cr stopping rule(s) for the trial.
#' @slot increments (`IncrementsOrdinal`)\cr how to control increments between dose levels.
#' @slot pl_cohort_size (`CohortSizeOrdinal`)\cr rules for the cohort sizes for placebo,
#'   if any planned (defaults to constant 0 placebo patients).
#'
#' @aliases DesignOrdinal
#' @export
#'
.DesignOrdinal <- setClass(
  Class = "DesignOrdinal",
  slots = c(
    model = "LogisticLogNormalOrdinal",
    stopping = "StoppingOrdinal",
    increments = "IncrementsOrdinal",
    pl_cohort_size = "CohortSizeOrdinal"
  ),
  prototype = prototype(
    model = .LogisticLogNormalOrdinal(),
    next_best = .NextBestOrdinal(),
    stopping = .StoppingOrdinal(),
    increments = .IncrementsOrdinal(),
    pl_cohort_size = CohortSizeOrdinal(1L, CohortSizeConst(3L))
  ),
  contains = "RuleDesignOrdinal"
)

## constructor ----

#' @rdname DesignOrdinal-class
#'
#' @param model (`LogisticLogNormalOrdinal`)\cr see slot definition.
#' @param stopping (`StoppingOrdinal`)\cr see slot definition.
#' @param increments (`IncrementsOrdinal`)\cr see slot definition.
#' @param pl_cohort_size (`CohortSizeOrdinal`)\cr see slot definition.
#' @inheritDotParams RuleDesignOrdinal
#'
#' @export
#' @example examples/Design-class-DesignOrdinal.R
#'
#'
DesignOrdinal <- function(
    model,
    stopping,
    increments,
    pl_cohort_size = CohortSizeOrdinal(1L, CohortSizeConst(0L)),
    ...) {
  start <- RuleDesignOrdinal(...)
  new(
    "DesignOrdinal",
    start,
    model = model,
    stopping = stopping,
    increments = increments,
    pl_cohort_size = pl_cohort_size
  )
}

## default constructor ----

#' @rdname DesignOrdinal-class
#' @note Typically, end users will not use the `.DefaultDesignOrdinal()` function.
#' @export
.DefaultDesignOrdinal <- function() {
  my_size1 <- CohortSizeRange(
    intervals = c(0, 30),
    cohort_size = c(1, 3)
  )
  my_size2 <- CohortSizeDLT(
    intervals = c(0, 1),
    cohort_size = c(1, 3)
  )
  my_size <- CohortSizeOrdinal(1L, maxSize(my_size1, my_size2))

  my_stopping1 <- StoppingMinCohorts(nCohorts = 3)
  my_stopping2 <- StoppingTargetProb(
    target = c(0.2, 0.35),
    prob = 0.5
  )
  my_stopping3 <- StoppingMinPatients(nPatients = 20)
  my_stopping <- StoppingOrdinal(1L, (my_stopping1 & my_stopping2) | my_stopping3)

  # Initialize the design.
  design <- DesignOrdinal(
    model = LogisticLogNormalOrdinal(
      mean = c(-3, -4, 1),
      cov = diag(c(3, 4, 1)),
      ref_dose = 50
    ),
    next_best = NextBestOrdinal(
      1L,
      NextBestNCRM(
        target = c(0.2, 0.35),
        overdose = c(0.35, 1),
        max_overdose_prob = 0.25
      )
    ),
    stopping = my_stopping,
    increments = IncrementsOrdinal(
      1L,
      IncrementsRelative(
        intervals = c(0, 20),
        increments = c(1, 0.33)
      )
    ),
    cohort_size = my_size,
    data = DataOrdinal(
      doseGrid = c(1, 3, 5, 10, 15, 20, 25, 40, 50, 80, 100),
      yCategories = c("No tox" = 0L, "Sub-tox AE" = 1L, "DLT" = 2L)
    ),
    starting_dose = 3
  )
}

# Validate-class ----

#' `Validate`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' The [`Validate`] class is a Reference Class
#' to help programming validation for new S4 classes.
#'
#' @details Starting from an empty `msg` vector, with each check
#'   that is returning `FALSE` the vector gets a new element - the string
#'   explaining the failure of the validation.
#'
#' @name Validate
#' @field msg (`character`)\cr the cumulative messages.
#'
Validate <- setRefClass(
  Class = "Validate",
  fields = list(msg = "character"),
  methods = list(
    check = function(test, string = "") {
      "Check whether the \\code{test} is \\code{TRUE}; if so, return \\code{NULL}.
      Otherwise, add the \\code{string} message into the cumulative messages vector \\code{msg}."
      assert_flag(test)
      assert_string(string)
      if (test) {
        NULL
      } else {
        msg <<- c(msg, string)
      }
    },
    result = function() {
      "Return either cumulative messages vector \\code{msg}
      (which contains the error messages from all the checks),
      or \\code{NULL}, if \\code{msg} is empty (i.e. all the checks were successful)."
      if (length(msg) > 0) {
        msg
      } else {
        TRUE
      }
    }
  )
)

# positive_number-class ----

#' `positive_number`
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' The [`positive_number`] class is a class to store not `NULL`, non `NA`,
#' finite and strictly positive numerical value. It is mainly used to store
#' reference dose value in model classes.
#'
#' @name positive_number
#'
positive_number <- setClass(
  Class = "positive_number",
  contains = "numeric",
  validity = function(object) {
    v <- Validate()
    v$check(
      test_number(object, finite = TRUE) && object > 0,
      "Object's value must be strictly positive"
    )
    v$result()
  }
)

# nolint start

##' Helper function for value matching with tolerance
##'
##' This is a modified version of \code{match} that supports tolerance.
##'
##' @param x the values to be matched
##' @param table the values to be matched against
##' @return A vector of the same length as \code{x} or
##'  empty vector if \code{table} is empty.
##'
##' @export
##' @keywords programming
match_within_tolerance <- function(x, table) {
  if (length(table) == 0) {
    return(integer())
  }

  as.integer(sapply(x, function(.x) {
    which(sapply(table, function(.table) {
      isTRUE(all.equal(.x, .table,
        tolerance = 1e-10,
        check.names = FALSE,
        check.attributes = FALSE
      ))
    }))[1]
  }))
}

##' checks for whole numbers (integers)
##'
##' @param x the numeric vector
##' @param tol the tolerance
##' @return TRUE or FALSE for each element of x
##'
##' @keywords internal
is.wholenumber <- function(x, tol = .Machine$double.eps^0.5) {
  abs(x - round(x)) < tol
}


##' Safe conversion to integer vector
##'
##' @param x the numeric vector
##' @return the integer vector
##'
##' @keywords internal
safeInteger <- function(x) {
  testres <- is.wholenumber(x)
  if (!all(testres)) {
    notInt <- which(!testres)
    stop(paste(
      "elements",
      paste(notInt, sep = ", "),
      "of vector are not integers!"
    ))
  }
  as.integer(x)
}

##' Shorthand for logit function
##'
##' @param x the function argument
##' @return the logit(x)
##'
##' @export
##' @keywords programming
logit <- function(x) {
  qlogis(x)
}

##' Shorthand for probit function
##'
##' @param x the function argument
##' @return the probit(x)
##'
##' @export
##' @keywords programming
probit <- function(x) {
  qnorm(x)
}

##' Open the example pdf for crmPack
##'
##' Calling this helper function should open the example.pdf document,
##' residing in the doc subfolder of the package installation directory.
##'
##' @return nothing
##' @export
##' @keywords documentation
##' @author Daniel Sabanes Bove \email{sabanesd@@roche.com}
crmPackExample <- function() {
  crmPath <- system.file(package = "crmPack")
  printVignette(list(PDF = "example.pdf", Dir = crmPath))
  ## instead of utils:::print.vignette
}

##' Open the browser with help pages for crmPack
##'
##' This convenience function opens your browser with the help pages for
##' crmPack.
##'
##' @return nothing
##' @export
##' @importFrom utils help
##' @keywords documentation
##' @author Daniel Sabanes Bove \email{sabanesd@@roche.com}
crmPackHelp <- function() {
  utils::help(package = "crmPack", help_type = "html")
}

#' Plot `gtable` Objects
#'
#' This is needed because `crmPack` uses [gridExtra::arrangeGrob()] to combine
#' `ggplot2` plots, and the resulting `gtable` object is not plotted otherwise
#' when implicitly printing it in the console, e.g.
#'
#' @method plot gtable
#' @param x (`gtable`)\cr object to plot.
#' @param ... additional parameters for [grid::grid.draw()].
#'
#' @export
plot.gtable <- function(x, ...) {
  grid::grid.draw(x, ...)
}

#' @method print gtable
#' @rdname plot.gtable
#' @export
print.gtable <- function(x, ...) {
  plot(x, ...)
}

##' Taken from utils package (print.vignette)
##'
##' @importFrom tools file_ext
##' @importFrom utils browseURL
##' @keywords internal
printVignette <- function(x, ...) {
  if (nzchar(out <- x$PDF)) {
    ext <- tools::file_ext(out)
    out <- file.path(x$Dir, "doc", out)
    if (tolower(ext) == "pdf") {
      pdfviewer <- getOption("pdfviewer")
      if (identical(pdfviewer, "false")) {
      } else if (.Platform$OS.type == "windows" && identical(
        pdfviewer,
        file.path(R.home("bin"), "open.exe")
      )) {
        shell.exec(out)
      } else {
        system2(pdfviewer, shQuote(out), wait = FALSE)
      }
    } else {
      browseURL(out)
    }
  } else {
    warning(gettextf("vignette %s has no PDF/HTML", sQuote(x$Topic)),
      call. = FALSE, domain = NA
    )
  }
  invisible(x)
}

##' Compute the density of Inverse gamma distribution
##' @param x vector of quantiles
##' @param a the shape parameter of the inverse gamma distribution
##' @param b the scale parameter of the inverse gamma distribution
##' @param log logical; if TRUE, probabilities p are given as log(p)
##' @param normalize logical; if TRUE, the output will be normalized
##'
##' @keywords internal
dinvGamma <- function(x,
                      a,
                      b,
                      log = FALSE,
                      normalize = TRUE) {
  ret <- -(a + 1) * log(x) - b / x
  if (normalize) {
    ret <- ret + a * log(b) - lgamma(a)
  }
  if (log) {
    return(ret)
  } else {
    return(exp(ret))
  }
}

##' Compute the distribution function of Inverse gamma distribution
##'
##' @param q vector of quantiles
##' @param a the shape parameter of the inverse gamma distribution
##' @param b the scale parameter of the inverse gamma distribution
##' @param lower.tail logical; if TRUE (default), probabilities are `P(X  > x)`,
##'   otherwise, `P(X <= x)`.
##' @param logical; FALSE (default) if TRUE, probabilities/densities p
##'   are returned as `log(p)`
##'
##' @keywords internal
pinvGamma <- function(q,
                      a,
                      b,
                      lower.tail = TRUE,
                      log.p = FALSE) {
  pgamma(
    q = 1 / q,
    shape = a,
    rate = b,
    lower.tail = !lower.tail,
    log.p = log.p
  )
}

##' Compute the quantile function of Inverse gamma distribution
##' @param p vector of probabilities
##' @param a the shape parameter of the inverse gamma distribution
##' @param b the scale parameter of the inverse gamma distribution
##' @param lower.tail logical; if TRUE (default), probabilities are `P(X  > x)`,
##'   otherwise, `P(X <= x)`.
##' @param logical; FALSE (default) if TRUE, probabilities/densities p are
##'   returned as `log(p)`
##'
##' @keywords internal
qinvGamma <- function(p,
                      a,
                      b,
                      lower.tail = TRUE,
                      log.p = FALSE) {
  1 / qgamma(
    p = p,
    shape = a,
    rate = b,
    lower.tail = !lower.tail,
    log.p = log.p
  )
}
##' The random generation of the Inverse gamma distribution
##' @param n the number of observations
##' @param a the shape parameter of the inverse gamma distribution
##' @param b the scale parameter of the inverse gamma distribution
##'
##' @keywords internal
rinvGamma <- function(n,
                      a,
                      b) {
  1 / rgamma(n,
    shape = a,
    rate = b
  )
}

# nolint end

#' Combining S4 Class Validation Results
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' A simple helper function that combines two outputs from calls to `result()`
#'   function which is placed in a slot of [Validate()] reference class.
#'
#' @param v1 (`logical` or `character`)\cr an output from `result()` function from
#'   [Validate()] reference class, to be combined with `v2`.
#' @param v2 (`logical` or `character`)\cr an output from `result()` function from
#'   [Validate()] reference class, to be combined with `v1`.
#'
#' @export
#' @examples
#' h_validate_combine_results(TRUE, "some_message")
h_validate_combine_results <- function(v1, v2) {
  assert_true(test_true(v1) || test_character(v1, any.missing = FALSE, min.len = 1L))
  assert_true(test_true(v2) || test_character(v2, any.missing = FALSE, min.len = 1L))

  isTRUEv2 <- isTRUE(v2)
  if (isTRUE(v1)) {
    if (isTRUEv2) {
      TRUE
    } else {
      v2
    }
  } else {
    if (isTRUEv2) {
      v1
    } else {
      c(v1, v2)
    }
  }
}

#' Comparison with Numerical Tolerance and Without Name Comparison
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' This helper function ensures a default tolerance level equal to `1e-10`,
#' and ignores names and other attributes.
#' In contrast to [all.equal()], it always returns a logical type object.
#'
#' @param target (`numeric`)\cr target values.
#' @param current (`numeric`)\cr current values.
#' @param tolerance (`number`) relative differences smaller than this are not
#'   reported.
#' @return `TRUE` when `target` and `current` do not differ
#'   up to desired tolerance and without looking at names or other attributes,
#'   `FALSE` otherwise.
#'
#' @export
#'
h_all_equivalent <- function(target,
                             current,
                             tolerance = 1e-10) {
  assert_numeric(target)
  assert_numeric(current)
  assert_number(tolerance)

  tmp <- all.equal(
    target = target,
    current = current,
    tolerance = tolerance,
    check.names = FALSE,
    check.attributes = FALSE
  )
  isTRUE(tmp)
}

#' Preparing Data for Plotting
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' This helper function prepares a `data.frame` object based on `Data` class
#' object. The resulting data frame is used by the plot function for `Data`
#' class objects.
#'
#' @param data (`Data`)\cr object from which data is extracted and converted
#'   into a data frame.
#' @param blind (`flag`)\cr should data be blinded?
#'   If `TRUE`, then for each cohort, all DLTs are assigned to the first
#'   subjects in the cohort. In addition, the placebo (if any) is set to the
#'   active dose level for that cohort.
#' @param ... further arguments passed to `data.frame` constructor.
#'   It can be e.g. an extra `column_name = value` pair based on a slot
#'   from `x` (which in this case might be a subclass of `Data`)
#'   which does not appear in `Data`.
#' @return A [`data.frame`] object with values to plot.
#'
h_plot_data_df <- function(data, blind = FALSE, ...) {
  df <- data.frame(
    patient = seq_along(data@x),
    ID = paste(" ", data@ID),
    cohort = data@cohort,
    dose = data@x,
    toxicity = ifelse(data@y == 1, "Yes", "No"),
    ...
  )

  if (blind) {
    # This is to blind the data.
    # For each cohort, all DLTs are assigned to the first subjects in the cohort.
    # In addition, the placebo (if any) is set to the active dose level for that
    # cohort.
    # Notice: dapply reorders records of df according to the lexicographic order
    # of cohort.
    df <- dapply(df, f = ~cohort, FUN = function(coh) {
      coh$toxicity <- sort(coh$toxicity, decreasing = TRUE)
      coh$dose <- max(coh$dose)
      coh
    })
  } else if (data@placebo) {
    # Placebo will be plotted at y = 0 level.
    df$dose[df$dose == data@doseGrid[1]] <- 0
  }

  df
}

#' Preparing Cohort Lines for Data Plot
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' This helper function prepares a `ggplot` geom with reference lines
#' separating different cohorts on the plot of `Data` class object.
#' Lines are either vertical or horizontal of green color and longdash type.
#'
#' @details The geom object is returned if and only if `placebo` is equal to
#'   `TRUE` and there are more than one unique values in `cohort`. Otherwise,
#'   this function returns `NULL` object.
#'
#' @param cohort (`integer`)\cr the cohort indices.
#' @param placebo (`flag`)\cr is placebo included in the doses?
#'   If it so, this function returns `NULL` object as in this case all doses
#'   in a given cohort are equal and there is no need to separate them.
#' @param vertical (`flag`)\cr should the line be vertical? Otherwise it is
#'   horizontal.
#'
h_plot_data_cohort_lines <- function(cohort,
                                     placebo,
                                     vertical = TRUE) {
  assert_integer(cohort)
  assert_flag(placebo)
  assert_flag(vertical)

  # If feasible, add vertical or horizontal green lines separating sub-sequent
  # cohorts.
  if (placebo && length(unique(cohort)) > 1) {
    intercept <- head(cumsum(table(cohort)), n = -1) + 0.5
    if (vertical) {
      geom_vline(xintercept = intercept, colour = "green", linetype = "longdash") # nolintr
    } else {
      geom_hline(yintercept = intercept, colour = "green", linetype = "longdash") # nolintr
    }
  } else {
    NULL
  }
}

#' Checking Formals of a Function
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' This helper function checks whether a given function `fun` has required or
#' allowed arguments. The argument check is based only on the names of the
#' arguments. No any further logic is verified here.
#'
#' @param fun (`function`)\cr a function name whose argument names will be
#'   checked.
#' @param mandatory (`character` or `NULL`)\cr the names of the arguments which
#'   must be present in `fun`. If `mandatory` is specified as `NULL` (default)
#'   this requirement is ignored.
#' @param allowed (`character` or `NULL`)\cr the names of the arguments which
#'   are allowed in `fun`. Names that do not belong to `allowed` are simply not
#'   allowed. The `allowed` parameter is independent from the `mandatory`, in a
#'   sense that if `mandatory` is specified as a `character` vector, it does not
#'   have to be repeated in `allowed`. If `allowed` is specified as `NULL`
#'   (default), then it means that there must be no any arguments in `fun`
#'   (except these ones which are specified in `mandatory`).
#'
#' @export
#'
h_check_fun_formals <- function(fun, mandatory = NULL, allowed = NULL) {
  assert_function(fun)
  assert_character(mandatory, null.ok = TRUE)
  assert_character(allowed, null.ok = TRUE)

  arg_names <- names(formals(fun))
  mandatory_check <- all(mandatory %in% arg_names)
  allowed_check <- all(arg_names %in% c(mandatory, allowed))

  mandatory_check && allowed_check
}

#' Getting the Slots from a S4 Object
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' This helper function extracts requested slots from the S4 class object.
#' It is a simple wrapper of [methods::slot()] function.
#'
#' @param object (`S4`)\cr an object from a formally defined S4 class.
#' @param names (`character`)\cr a vector with names of slots to be fetched.
#'   This function assumes that for every element in `names`, there exists a
#'   slot of the same name in the `object`.
#' @param simplify (`flag`)\cr should an output be simplified? This has an
#'   effect if and only if a single slot is about to be extracted, i.e.
#'   `names` is just a single string.
#'
#' @return `list` with the slots extracted from `object` according to `names`,
#'   or single slot if simplification is required and possible.
#'
#' @export
#'
h_slots <- function(object, names, simplify = FALSE) {
  assert_true(isS4(object))
  assert_character(names, any.missing = FALSE, null.ok = TRUE)
  assert_true(all(names %in% slotNames(object)))

  if (is.null(names) || length(names) == 0L) {
    return(list())
  }

  slots_list <- sapply(names, function(n) slot(object, n), simplify = FALSE, USE.NAMES = TRUE)

  if (simplify && length(names) == 1) {
    slots_list[[1]]
  } else {
    slots_list
  }
}

#' Conditional Formatting Using C-style Formats
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' This helper function conditionally formats a number with [formatC()]
#' function using `"E"` format and specific number of digits as given by the
#' user. A number is formatted if and only if its absolute value is less than
#' `0.001` or greater than `10000`. Otherwise, the number is not formatted.
#' Additionally, custom prefix or suffix can be appended to character string
#' with formatted number, so that the changes are marked.
#'
#' @note This function was primarily designed as a helper for
#'   [h_jags_write_model()] function.
#'
#' @param x (`number`)\cr a number to be formatted.
#' @param digits (`function`)\cr the desired number of significant digits.
#' @param prefix (`string`)\cr a prefix to be added in front of the formatted
#'   number.
#' @param suffix (`string`)\cr a suffix to be appended after the formatted
#'   number.
#'
#' @return Either formatted `x` as `string` or unchanged `x` if the
#'   formatting condition is not met.
#'
#' @export
#' @examples
#' h_format_number(50000)
#' h_format_number(50000, prefix = "P", suffix = "S")
h_format_number <- function(x,
                            digits = 5,
                            prefix = "",
                            suffix = "") {
  assert_number(x)
  assert_int(digits)
  assert_string(prefix)
  assert_string(suffix)

  if ((abs(x) < 1e-3) || (abs(x) > 1e+4)) {
    paste0(prefix, formatC(x, digits = digits, format = "E"), suffix)
  } else {
    x
  }
}

#' Recursively Apply a Function to a List
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' This helper function recursively iterates through a "list-like" object and it
#' checks whether an element is of a given class. If it so, then it replaces
#' that element by the result of an execution of a given function. Otherwise,
#' and if the element is of length greater than 1 (i.e. not a scalar), it
#' replaces that element by the result of `h_rapply()`, recursively called for
#' that element. In the remaining case, that is, the element is not of a given
#' class and is a scalar, then that element remains unchanged.
#'
#' @note This helper function is conceptually similar the same as [rapply()]
#'   function. However, it differs from [rapply()] in two major ways. First, the
#'   `h_rapply()` is not limited to objects of type `list` or `expression` only.
#'   It can be any "list-like" object of any type for which subsetting operator
#'   [`[[`][Extract] is defined. This can be, for example, an object of type
#'   `language`, often obtained from the [body()] function. The second
#'   difference is that the flexibility of [rapply()] on how the result is
#'   structured is not available with `h_rapply()` for the user. That is, with
#'   `h_rapply()` each element of `x`, which has a class included in `classes`,
#'   is replaced by the result of applying `fun` to the element. This behavior
#'   corresponds to [rapply()] when invoked with fixed `how = replace`.
#'   This function was primarily designed as a helper for [h_jags_write_model()]
#'   function.
#'
#' @param x (`any`)\cr "list-like" object for which subsetting operator
#'   [`[[`][Extract] is defined.
#' @param fun (`function`)\cr a function of one "principal" argument, passing
#'   further arguments via `...`.
#' @param classes (`character`)\cr class names.
#' @param ... further arguments passed to function `fun`.
#'
#' @return "list-like" object of similar structure as `x`.
#'
#' @export
#' @example examples/helpers-rapply.R
#'
h_rapply <- function(x, fun, classes, ...) {
  assert_function(fun)
  assert_character(classes, min.len = 1L)
  # To assert that `x` is subsettable.
  # If it works, fine, we don't see the result, otherwise it gives the error.
  force(x[[1]])

  for (i in seq_along(x)) {
    if (class(x[[i]]) %in% classes) {
      x[[i]] <- do.call(fun, c(list(x[[i]]), ...))
    } else if (length(x[[i]]) > 1L) {
      x[[i]] <- h_rapply(x[[i]], fun, classes, ...)
    }
  }
  x
}

#' Getting `NULL` for `NA`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' A simple helper function that replaces `NA` object by `NULL` object.
#'
#' @param x (`any`)\cr atomic object of length `1`. For the definition of
#'   "atomic", see [is.atomic()].
#'
#' @return `NULL` if `x` is `NA`, otherwise, `x`.
#'
#' @export
#' @examples
#' h_null_if_na(NA)
h_null_if_na <- function(x) {
  assert_atomic(x, len = 1L)

  if (is.na(x)) {
    NULL
  } else {
    x
  }
}

#' Getting the default value for an empty object
#'
#' @description `r lifecycle::badge("stable")`
#'
#' A simple helper function that sets a default value for an empty object,
#' that is an object for which [length()] function returns `0L`.
#'
#' @param x (`any`) \cr an object to handle. It can be any object for which
#'   [length()] function is defined.
#' @param default (`any`) \cr a default value for `x` object.
#'
#' @export
#' @examples
#' h_default_if_empty(character(0), default = "default label")
#' h_default_if_empty("custom label", default = "default label")
#' h_default_if_empty(NA, default = "default label")
h_default_if_empty <- function(x, default) {
  if (length(x) == 0L) {
    default
  } else {
    x
  }
}
#' Testing Matrix for Positive Definiteness
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' This helper function checks whether a given numerical matrix `x` is a
#' positive-definite square matrix of a given size, without any missing
#' values. This function is used to test if a given matrix is a covariance
#' matrix, since every symmetric positive semi-definite matrix is a covariance
#' matrix.
#'
#' @details The positive definiteness test implemented in this function
#'   is based on the following characterization valid for real matrices:
#'   `A symmetric matrix is positive-definite if and only if all of its
#'   eigenvalues are positive.` In this function an eigenvalue is considered
#'   as positive if and only if it is greater than the `tol`.
#'
#' @param x (`matrix`)\cr a matrix to be checked.
#' @param size (`integer`)\cr a size of the square matrix `x` to be checked
#'   against for.
#' @param tol (`number`)\cr a given tolerance number used to check whether
#'   an eigenvalue is positive or not. An eigenvalue is considered
#'   as positive if and only if it is greater than the `tol`.
#'
#' @return `TRUE` if a given matrix is a positive-definite, `FALSE` otherwise.
#'
#' @export
#'
h_is_positive_definite <- function(x, size = 2, tol = 1e-08) {
  assert_number(tol)

  is_matrix <- test_matrix(
    x,
    mode = "numeric", nrows = size, ncols = size, any.missing = FALSE
  )

  if (is_matrix) {
    is_symmetric <- all.equal(x, t(x), tolerance = tol)
    if (isTRUE(is_symmetric)) {
      ev <- eigen(x, only.values = TRUE)$values
      all(ev > tol)
    } else {
      FALSE
    }
  } else {
    FALSE
  }
}

#' Check that an argument is a named vector of type numeric
#'
#' @description `r lifecycle::badge("stable")`
#'
#' A simple helper function that tests whether an object is a named numerical
#' vector.
#'
#' @note This function is based on [`checkmate::test_numeric()`] and
#'   [`checkmate::test_names()`] functions.
#'
#' @param x (`any`)\cr object to check.
#' @inheritParams checkmate::test_names
#' @inheritParams checkmate::test_numeric
#' @param ... further parameters passed to [`checkmate::test_numeric()`].
#'
#' @return `TRUE` if `x` is a named vector of type numeric, otherwise `FALSE`.
#'
#' @export
#' @examples
#' h_test_named_numeric(1:2, permutation.of = c("a", "b"))
#' h_test_named_numeric(c(a = 1, b = 2), permutation.of = c("a", "b"))
#' h_test_named_numeric(c(a = 1, b = 2), permutation.of = c("b", "a"))
h_test_named_numeric <- function(x,
                                 subset.of = NULL, # nolintr
                                 must.include = NULL, # nolintr
                                 permutation.of = NULL, # nolintr
                                 identical.to = NULL, # nolintr
                                 disjunct.from = NULL, # nolintr
                                 lower = 0 + .Machine$double.xmin,
                                 finite = TRUE,
                                 any.missing = FALSE, # nolintr
                                 len = 2,
                                 ...) {
  is_valid_num <- test_numeric(
    x,
    lower = lower,
    finite = finite,
    any.missing = any.missing,
    len = len,
    ...,
    names = "named"
  )
  are_names_valid <- test_names(
    names(x),
    subset.of = subset.of,
    must.include = must.include,
    permutation.of = permutation.of,
    identical.to = identical.to,
    disjunct.from = disjunct.from,
  )
  is_valid_num && are_names_valid
}

#' Check which elements are in a given range
#'
#' @description `r lifecycle::badge("stable")`
#'
#' A simple helper function that tests whether elements of a given vector or
#' matrix are within specified interval.
#'
#' @param x (`numeric`)\cr vector or matrix with elements to test.
#' @param range (`numeric`)\cr an interval, i.e. sorted two-elements vector.
#' @param bounds_closed (`logical`)\cr should bounds in the `range` be treated
#'   as closed? This can be a scalar or vector of length two. If it is a scalar,
#'   then its value applies to lower bound `range[1]` and upper bound
#'   `range[2]`. If this is a vector with two flags, the first flag corresponds
#'   to the lower bound only, and the second to the upper bound only.
#'
#' @return A logical vector or matrix of length equal to the length of `x`, that
#'   for every element of `x`, indicates whether a given element of `x` is in
#'   the `range`.
#'
#' @export
#' @examples
#' x <- 1:4
#' h_in_range(x, range = c(1, 3))
#' h_in_range(x, range = c(1, 3), bounds_closed = FALSE)
#' h_in_range(x, range = c(1, 3), bounds_closed = c(FALSE, TRUE))
#' mat <- matrix(c(2, 5, 3, 10, 4, 9, 1, 8, 7), nrow = 3)
#' h_in_range(mat, range = c(1, 5))
h_in_range <- function(x, range = c(0, 1), bounds_closed = TRUE) {
  assert_numeric(x)
  assert_numeric(range, any.missing = FALSE, len = 2, sorted = TRUE)
  assert_logical(bounds_closed, min.len = 1, max.len = 2, any.missing = FALSE)

  above_lwr <- if (bounds_closed[1]) {
    x >= range[1]
  } else {
    x > range[1]
  }

  below_upr <- if (tail(bounds_closed, 1)) {
    x <= range[2]
  } else {
    x < range[2]
  }

  above_lwr & below_upr
}

#' Find Interval Numbers or Indices and Return Custom Number For 0.
#'
#' @description `r lifecycle::badge("stable")`
#'
#' A simple wrapper of [`findInterval()`] function that invokes
#' [`findInterval()`], takes its output and replaces all the
#' elements with \eqn{0} value to a custom number as specified in `replacement`
#' argument.
#'
#' @inheritDotParams base::findInterval
#' @param replacement (`number`)\cr a custom number to be used as a replacement
#'   for \eqn{0}. Default to `-Inf`.
#'
#' @export
#' @examples
#' h_find_interval(1, c(2, 4, 6))
#' h_find_interval(3, c(2, 4, 6))
#' h_find_interval(1, c(2, 4, 6), replacement = -1)
h_find_interval <- function(..., replacement = -Inf) {
  assert_number(replacement)

  x <- findInterval(...)
  ifelse(x == 0, yes = replacement, no = x)
}



#' Group Together Mono and Combo Data
#'
#' This is only used in the simulation method for `DesignGrouped` to combine
#' the separately generated data sets from mono and combo arms and to fit the
#' combined logistic regression model.
#' Hence the ID and cohort information is not relevant and will be
#' arbitrarily assigned to avoid problems with the [`DataGrouped`] validation.
#'
#' @param mono_data (`Data`)\cr mono data.
#' @param combo_data (`Data`)\cr combo data.
#'
#' @return A [`DataGrouped`] object containing both `mono_data` and `combo_data`,
#'   but with arbitrary ID and cohort slots.
#'
#' @keywords internal
h_group_data <- function(mono_data, combo_data) {
  assert_class(mono_data, "Data")
  assert_class(combo_data, "Data")

  df <- data.frame(
    x = c(mono_data@x, combo_data@x),
    y = c(mono_data@y, combo_data@y),
    group = rep(c("mono", "combo"), c(length(mono_data@x), length(combo_data@x)))
  )
  df <- df[order(df$x), ]

  DataGrouped(
    x = df$x,
    y = df$y,
    ID = seq_along(df$x),
    cohort = as.integer(factor(df$x)),
    doseGrid = sort(unique(c(mono_data@doseGrid, combo_data@doseGrid))),
    group = df$group
  )
}

#' Helper Function to Set and Save the RNG Seed
#'
#' @description `r lifecycle::badge("stable")`
#'
#' This code is basically copied from `stats:::simulate.lm`.
#'
#' @param seed an object specifying if and how the random number generator
#' should be initialized ("seeded"). Either `NULL` (default) or an
#' integer that will be used in a call to [set.seed()] before
#' simulating the response vectors. If set, the value is saved as the
#' `seed` slot of the returned object. The default, `NULL` will
#' not change the random generator state.
#' @return The integer vector containing the random number generate state will
#' be returned, in order to call this function with this input to reproduce
#' the obtained simulation results.
#'
#' @export
set_seed <- function(seed = NULL) {
  assert_number(seed, null.ok = TRUE)

  if (!exists(".Random.seed", envir = .GlobalEnv, inherits = FALSE)) {
    runif(1)
  }

  if (is.null(seed)) {
    get(".Random.seed", envir = .GlobalEnv)
  } else {
    seed <- as.integer(seed)
    r_seed <- get(".Random.seed", envir = .GlobalEnv)
    # Make sure r_seed exists in parent frame.
    assign(".r_seed", r_seed, envir = parent.frame())
    set.seed(seed)
    # Here we need the r_seed in the parent.frame!
    do.call(
      "on.exit",
      list(quote(assign(".Random.seed", .r_seed, envir = .GlobalEnv))),
      envir = parent.frame()
    )
    structure(seed, kind = as.list(RNGkind()))
  }
}

#' Helper Function to Obtain Simulation Results List
#'
#' The function `fun` can use variables that are visible to itself.
#' The names of these variables have to be given in the vector `vars`.
#'
#' @param fun (`function`)\cr the simulation function for a single iteration, which takes as
#' single parameter the iteration index.
#' @param nsim number of simulations to be conducted.
#' @param vars names of the variables.
#' @param parallel should the simulation runs be parallelized across the
#' clusters of the computer?
#' @param n_cores how many cores should be used for parallel computing?
#' @return The list with all simulation results (one iteration corresponds
#' to one list element).
#'
#' @importFrom parallel makeCluster
#' @importFrom parallelly availableCores
#' @keywords internal programming
get_result_list <- function(
    fun,
    nsim,
    vars,
    parallel,
    n_cores) {
  assert_flag(parallel)
  assert_integerish(n_cores, lower = 1)

  if (!parallel) {
    lapply(
      X = seq_len(nsim),
      FUN = fun
    )
  } else {
    # Process all simulations.
    cores <- min(
      as.integer(n_cores),
      parallelly::availableCores()
    )

    # Start the cluster.
    cl <- parallel::makeCluster(cores)

    # Load the required R package.
    parallel::clusterEvalQ(cl, {
      library(crmPack)
      NULL
    })

    # Export local variables from the caller environment.
    # Note: parent.frame() is different from parent.env() which returns
    # the environment where this function has been defined!
    parallel::clusterExport(
      cl = cl,
      varlist = vars,
      envir = parent.frame()
    )

    # Export all global variables.
    parallel::clusterExport(
      cl = cl,
      varlist = ls(.GlobalEnv)
    )

    # Load user extensions from global options.
    crmpack_extensions <- getOption("crmpack_extensions")
    if (is.null(crmpack_extensions) != TRUE) {
      tryCatch(
        {
          parallel::clusterCall(cl, crmpack_extensions)
        },
        error = function(e) {
          stop("Failed to export crmpack_extensions: ", e$message)
        }
      )
    }

    # Do the computations in parallel.
    res <- parallel::parLapply(
      cl = cl,
      X = seq_len(nsim),
      fun = fun
    )

    # Stop the cluster.
    parallel::stopCluster(cl)

    res
  }
}




#' Helper Function to call truth calculation
#'
#' @param dose (`number`)\cr current dose.
#' @param truth (`function`)\cr defines the true probability for a DLT at a dose.
#' @param this_args (`data.frame`)\cr list of arguments for the truth.
#' @return The updated `this_truth`.
#'
#' @keywords internal
h_this_truth <- function(dose, this_args, truth) {
  do.call(
    truth,
    ## First argument: the dose
    c(
      dose,
      ## Following arguments
      this_args
    )
  )
}


#' Helper Function to create return list for Simulations output
#'
#' @param resultList (`list`)\cr raw iteration output.
#'
#' @return aggregated output for simulation object `list`.
#'
#' @keywords internal
h_simulations_output_format <- function(resultList) {
  ## put everything in the Simulations format:

  ## setup the list for the simulated data objects
  dataList <- lapply(resultList, "[[", "data")

  ## the vector of the final dose recommendations
  recommendedDoses <- as.numeric(sapply(resultList, "[[", "dose"))

  ## setup the list for the final fits
  fitList <- lapply(resultList, "[[", "fit")

  ## the reasons for stopping
  stopReasons <- lapply(resultList, "[[", "stop")

  # individual stopping rule results as matrix, labels as column names
  stopResults <- lapply(resultList, "[[", "report_results")
  stop_matrix <- as.matrix(do.call(rbind, stopResults))

  # Result list of additional statistical summary.
  additional_stats <- lapply(resultList, "[[", "additional_stats")

  return(list(
    dataList = dataList,
    recommendedDoses = recommendedDoses,
    fitList = fitList,
    stopReasons = stopReasons,
    stopResults = stopResults,
    additional_stats = additional_stats,
    stop_matrix = stop_matrix
  ))
}


#' Helper function to recursively unpack stopping rules and return lists with
#' logical value and label given
#'
#' @param stopit_tree object from simulate method
#' @return named list

h_unpack_stopit <- function(stopit_tree) {
  label <- attr(stopit_tree, "report_label")
  value <- stopit_tree[1]
  names(value) <- label
  value
  if (is.null(attr(stopit_tree, "individual"))) {
    return(value)
  } else {
    return(unlist(c(value, lapply(attr(stopit_tree, "individual"), h_unpack_stopit))))
  }
}



#' Helper function to determine the dlts including first separate and placebo
#' condition
#'
#' @param data (`Data`)\cr what data to start from.
#' @param dose (`number`)\cr current dose.
#' @param prob (`function`)\cr defines the true probability for a DLT at a dose.
#' @param prob_placebo (`function`)\cr defines the true probability for a DLT at a placebo condition.
#' @param cohort_size (`number`)\cr the cohort size to use.
#' @param cohort_size_placebo (`number`)\cr the cohort size to use for placebo condition.
#' @param dose_grid (`numeric`)\cr the dose_grid as specified by the user.
#' @param first_separate (`flag`)\cr whether the first patient is enrolled separately.
#' @return updated data object
#' @keywords internal


h_determine_dlts <- function(data,
                             dose,
                             prob,
                             prob_placebo,
                             cohort_size,
                             cohort_size_placebo,
                             dose_grid,
                             first_separate) {
  assert_class(data, "Data")
  assert_number(dose)
  assert_number(prob)
  assert_number(cohort_size)
  assert_flag(first_separate)

  if (first_separate && cohort_size > 1) {
    dlts <- rbinom(n = 1, size = 1, prob = prob)
    if ((data@placebo) && cohort_size_placebo > 0) {
      dlts_placebo <- rbinom(n = 1, size = 1, prob = prob_placebo)
    }
    if (dlts == 0) {
      dlts <- c(dlts, rbinom(n = cohort_size - 1L, size = 1, prob = prob))
      if ((data@placebo) && cohort_size_placebo > 0) {
        dlts_placebo <- c(dlts_placebo, rbinom(
          n = cohort_size_placebo, # cohort_size_placebo - 1?
          size = 1,
          prob = prob_placebo
        ))
      }
    }
  } else {
    dlts <- rbinom(n = cohort_size, size = 1, prob = prob)
    if ((data@placebo) && cohort_size_placebo > 0) {
      dlts_placebo <- rbinom(n = cohort_size_placebo, size = 1, prob = prob_placebo)
    }
  }


  if ((data@placebo) && cohort_size_placebo > 0) {
    this_data <- update(
      object = data,
      x = dose_grid,
      y = dlts_placebo,
      check = FALSE
    )

    ## update the data with active dose
    this_data <- update(
      object = this_data,
      x = dose,
      y = dlts,
      new_cohort = FALSE
    )
  } else {
    ## update the data with this cohort
    this_data <- update(
      object = data,
      x = dose,
      y = dlts
    )
  }
  return(this_data)
}

# Design ----

#' Internal Helper Functions for Validation of [`RuleDesign`] Objects
#'
#' @description `r lifecycle::badge("stable")`
#'
#' These functions are only used internally to validate the format of an input
#' [`RuleDesign`] or inherited classes and therefore not exported.
#'
#' @name v_design
#' @param object (`RuleDesign`)\cr object to validate.
#' @return A `character` vector with the validation failure messages,
#'   or `TRUE` in case validation passes.
NULL

#' @describeIn v_design validates that the [`RuleDesign`] object
#'   contains valid `startingDose`.
v_rule_design <- function(object) {
  v <- Validate()
  v$check(
    test_number(object@startingDose, finite = TRUE),
    "startingDose must be a number"
  )
  v$check(
    test_subset(object@startingDose, choices = object@data@doseGrid, empty.ok = FALSE),
    "startingDose must be included in data@doseGrid"
  )
  v$result()
}

#' Internal Helper Functions for Validation of [`RuleDesignOrdinal`] Objects
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' These functions are only used internally to validate the format of an input
#' [`RuleDesignOrdinal`] or inherited classes and therefore not exported.
#'
#' @name v_design
#' @param object (`RuleDesignOrdinal`)\cr object to validate.
#' @return A `character` vector with the validation failure messages,
#'   or `TRUE` in case validation passes.
NULL

#' @describeIn v_design validates that the [`RuleDesignOrdinal`] object
#'   contains valid `starting_dose`.
v_rule_design_ordinal <- function(object) {
  v <- Validate()
  v$check(
    test_number(object@starting_dose, finite = TRUE),
    "starting_dose must be a number"
  )
  v$check(
    test_subset(object@starting_dose, choices = object@data@doseGrid, empty.ok = FALSE),
    "starting_dose must be included in data@doseGrid"
  )
  v$result()
}


#' @describeIn v_design validates that the [`DesignGrouped`] object
#'   contains valid flags.
v_design_grouped <- function(object) {
  v <- Validate()
  v$check(
    test_flag(object@first_cohort_mono_only),
    "first_cohort_mono_only must be a flag"
  )
  v$check(
    test_flag(object@same_dose_for_all),
    "same_dose_for_all must be a flag"
  )
  v$check(
    test_flag(object@same_dose_for_all),
    "same_dose_for_start must be a flag"
  )
  v$check(
    test_flag(object@stop_mono_with_combo),
    "stop_mono_with_combo must be a flag"
  )
  v$result()
}

#' Update [`DualEndpoint`] class model components with regard to biomarker
#' regression variance.
#'
#' @description `r lifecycle::badge("stable")`
#'
#' A simple helper function that takes [`DualEndpoint`] model existing components
#' (`priormodel`, `modelspecs`, `init`, `sample`), and updates them with regard to
#' to biomarker regression variance `sigma2W`.
#'
#' @param use_fixed (`flag`)\cr indicates whether a fixed value for the biomarker
#'   regression variance `sigma2W` should be used or not. If `sigma2W` is not
#'   supposed to be a fixed value, a prior distribution from the Inverse-Gamma
#'   distribution will be used. See the details below, under `sigma2W` argument.
#' @param sigma2W (`numeric`)\cr the biomarker variance. Either a fixed value or
#'   Inverse-Gamma distribution parameters, i.e. vector with two elements named
#'   `a` and `b`.
#' @param comp (`list`)\cr a named list with model components that will be updated.
#'   The names should be: `priormodel`, `modelspecs`, `init`, `sample`. For
#'   definitions of the components, see [`GeneralModel`] class.
#'   The `modelspecs` and `init` components on `comp` list are specified up to
#'   the body of corresponding `GeneralModel@modelspecs` and `GeneralModel@init`
#'   functions. These bodies are simply a lists itself.
#'
#' @return `list` with updated model components.
#'
#' @export
h_model_dual_endpoint_sigma2W <- function(use_fixed, # nolintr
                                          sigma2W,
                                          comp) {
  if (use_fixed) {
    assert_number(sigma2W, lower = 0 + .Machine$double.xmin, finite = TRUE)
    comp$modelspecs$precW <- 1 / sigma2W
  } else {
    assert_true(h_test_named_numeric(sigma2W, permutation.of = c("a", "b")))
    comp$priormodel <- h_jags_join_models(
      comp$priormodel,
      function() {
        precW ~ dgamma(precWa, precWb)
      }
    )
    comp$modelspecs$precWa <- sigma2W[["a"]]
    comp$modelspecs$precWb <- sigma2W[["b"]]
    comp$init$precW <- 1
    comp$sample <- c(comp$sample, "precW")
  }
  comp
}

#' Update [`DualEndpoint`] class model components with regard to DLT and biomarker
#' correlation.
#'
#' @description `r lifecycle::badge("stable")`
#'
#' A simple helper function that takes [`DualEndpoint`] model existing components
#' (`priormodel`, `modelspecs`, `init`, `sample`), and updates them with regard to
#' DLT and biomarker correlation `rho`.
#'
#' @param use_fixed (`flag`)\cr indicates whether a fixed value for DLT and
#'   biomarker correlation `rho` should be used or not. If `rho` is not supposed
#'   to be a fixed value, a prior distribution from the scaled Beta family will
#'   be used. See the details below, under `rho` argument.
#' @param rho (`numeric`)\cr DLT and biomarker correlation. It must be either a
#'   fixed value (between `-1` and `1`), or a named vector with two elements,
#'   named `a` and `b` for the Beta prior on the transformation
#'   `kappa = (rho + 1) / 2`, which is in `(0, 1)`. For example, `a = 1, b = 1`
#'   leads to a uniform prior on `rho`.
#' @param comp (`list`)\cr a named list with model components that will be updated.
#'   The names should be: `priormodel`, `modelspecs`, `init`, `sample`. For
#'   definitions of the components, see [`GeneralModel`] class.
#'   The `modelspecs` and `init` components on `comp` list are specified up to
#'   the body of corresponding `GeneralModel@modelspecs` and `GeneralModel@init`
#'   functions. These bodies are simply a lists itself.
#'
#' @return A `list` with updated model components.
#'
#' @export
h_model_dual_endpoint_rho <- function(use_fixed,
                                      rho,
                                      comp) {
  rmin <- .Machine$double.xmin
  if (use_fixed) {
    assert_number(rho, lower = -1 + rmin, upper = 1 - rmin)
    comp$modelspecs$rho <- rho
  } else {
    assert_true(h_test_named_numeric(rho, permutation.of = c("a", "b")))
    comp$priormodel <- h_jags_join_models(
      comp$priormodel,
      function() {
        kappa ~ dbeta(rhoa, rhob)
        rho <- 2 * kappa - 1
      }
    )
    comp$modelspecs$rhoa <- rho[["a"]]
    comp$modelspecs$rhob <- rho[["b"]]
    comp$init$kappa <- 0.5
    comp$sample <- c(comp$sample, "rho")
  }
  comp
}

#' Update certain components of [`DualEndpoint`] model with regard to prior variance
#' factor of the random walk.
#'
#' @description `r lifecycle::badge("stable")`
#'
#' A simple helper function that takes [`DualEndpoint`] object and updates
#' `priormodel`, `modelspecs`, `init`, `sample` slots according to the random walk
#' variance.
#'
#' @param use_fixed (`flag`)\cr indicates whether a fixed value for
#'   `sigma2betaW` should be used or not. If `sigma2betaW` is not supposed
#'   to be a fixed value, a prior distribution from the Inverse-Gamma distribution
#'   will be used. See the details below, under `sigma2betaW` argument.
#' @param sigma2betaW (`numeric`)\cr the prior variance factor of the random walk
#'   prior for the biomarker model. Either a fixed value or Inverse-Gamma distribution
#'   parameters, i.e. vector with two elements named `a` and `b`.
#' @param de (`DualEnpoint`)\cr dual endpoint model whose slots will be updated.
#'
#' @return A [`DualEndpoint`] model with updated `priormodel`, `modelspecs`,
#'   `init`, `sample` slots.
#'
#' @seealso [`DualEndpointRW`].
#' @export
h_model_dual_endpoint_sigma2betaW <- function(use_fixed, # nolintr
                                              sigma2betaW,
                                              de) {
  modelspecs <- de@modelspecs
  init <- de@init

  if (use_fixed) {
    assert_number(sigma2betaW, lower = 0 + .Machine$double.xmin, finite = TRUE)
    ms <- list(precBetaW = 1 / sigma2betaW)
  } else {
    assert_true(h_test_named_numeric(sigma2betaW, permutation.of = c("a", "b")))
    # gamma prior for random walk precision.
    de@priormodel <- h_jags_join_models(
      de@priormodel,
      function() {
        precBetaW ~ dgamma(precBetaWa, precBetaWb)
      }
    )
    ms <- list(precBetaWa = sigma2betaW[["a"]], precBetaWb = sigma2betaW[["b"]])
    de@init <- function(y) {
      c(init(y), list(precBetaW = 1))
    }
    de@sample <- c(de@sample, "precBetaW")
  }
  de@modelspecs <- function(from_prior) {
    c(modelspecs(from_prior), ms)
  }
  de
}

#' Update certain components of [`DualEndpoint`] model with regard to parameters
#' of the function that models dose-biomarker relationship defined in the
#' [`DualEndpointBeta`] class.
#'
#' @description `r lifecycle::badge("stable")`
#'
#' A simple helper function that takes [`DualEndpoint`] object and updates
#' `use_fixed`, `priormodel`, `modelspecs`, `init`, `sample` slots with regard
#' to a given parameter of the dose-biomarker relationship \eqn{f(x)} defined in
#' the [`DualEndpointBeta`] class. This update solely depends on whether a given
#' parameter's value `param` is a fixed-valued scalar or two-elements numeric
#' vector. In the later case, it is assumed that `param` represents two
#' parameters of a probability distribution that will be used in `priormodel`
#' function to generate values for the `param_name` parameter of \eqn{f(x)}.
#' See the help page for [`DualEndpointBeta`] class for more details.
#'
#' @param param (`numeric`)\cr the value of a given `param_name` parameter of
#'   the dose-biomarker relationship function \eqn{f(x)}. Either a fixed-valued
#'   scalar or vector with two elements that are the parameters of a probability
#'   distribution that will be used in `priormodel` function to generate values
#'   for the `param_name` parameter of \eqn{f(x)}.
#' @param param_name (`string`)\cr the name of the parameter of \eqn{f(x)},
#'   whose value depends on `param`.
#' @param param_suffix (`character`)\cr the two suffixes to be appended to
#'   the elements of `param_name` and then used when updating `modelspecs`.
#'   The value of this argument is ignored when `param` is a scalar.
#' @param priormodel (`function` or `NULL`)\cr a function representing the
#'   `JAGS` prior specification that will be appended to existing
#'   `de@priormodel` specification if `param` is not a scalar. Otherwise,
#'   `de@priormodel` remains unchanged.
#' @param de (`DualEnpoint`)\cr dual endpoint model whose slots will be updated.
#'
#' @return A [`DualEndpoint`] model with updated `use_fixed`, `priormodel`,
#'   `modelspecs`, `init`, `sample` slots.
#'
#' @export
h_model_dual_endpoint_beta <- function(param,
                                       param_name,
                                       param_suffix = c("_low", "_high"),
                                       priormodel = NULL,
                                       de) {
  assert_numeric(param, min.len = 1, max.len = 2, any.missing = FALSE)
  assert_string(param_name)
  assert_class(de, "DualEndpoint")

  use_fixed <- setNames(test_number(param), param_name)
  modelspecs <- de@modelspecs
  init <- de@init

  if (use_fixed) {
    ms <- setNames(list(param), param_name)
  } else {
    assert_character(param_suffix, len = 2, unique = TRUE, any.missing = FALSE)
    assert_function(priormodel)
    param_name2 <- paste0(param_name, param_suffix)

    de@priormodel <- h_jags_join_models(
      de@priormodel,
      priormodel
    )
    ms <- setNames(list(param[1], param[2]), param_name2)
    de@init <- function(y) {
      c(init(y), setNames(list(mean(param)), param_name))
    }
    de@sample <- c(de@sample, param_name)
  }
  de@modelspecs <- function(from_prior) {
    c(modelspecs(from_prior), ms)
  }
  de@use_fixed <- c(de@use_fixed, use_fixed)
  de
}

#' Convert an ordinal CRM model to the Equivalent Binary CRM Model for a Specific
#' Grade
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' A simple helper function that takes a [`LogisticLogNormalOrdinal`] and an
#' integer grade and converts them to the equivalent `LogisticLogNormal` model.
#'
#' @param x (`LogisticLogNormalOrdinal`)\cr the `LogisticLogNormalOrdinal`
#'   model to covert
#' @param grade (`integer`)\cr the toxicity grade for which the equivalent model
#' is required.
#' @return A [`LogisticLogNormal`] model.
#'
#' @export
h_convert_ordinal_model <- function(x, grade) {
  # Validate
  assert_integer(grade, len = 1, lower = 1)
  assert_class(x, "LogisticLogNormalOrdinal")
  # Execute
  LogisticLogNormal(
    mean = x@params@mean[-grade],
    cov = x@params@cov[-grade, -grade],
    ref_dose = x@ref_dose
  )
}

#' @include helpers.R
#' @include helpers_covr.R
#' @include logger.R
#' @include Samples-class.R
NULL

# mcmc ----

#' Obtaining Posterior Samples for all Model Parameters
#'
#' @description `r lifecycle::badge("stable")`
#'
#' This is the function that actually runs the `JAGS` MCMC machinery to produce
#' posterior samples from all model parameters and required derived values.
#' It is a generic function, so that customized versions may be conveniently
#' defined for specific subclasses of [`GeneralData`], [`GeneralModel`], and
#' [`McmcOptions`] input.
#'
#' @note The type of Random Number Generator (RNG) and its initial seed used by
#'   `JAGS` are taken from the `options` argument. If no initial values are
#'   supplied (i.e RNG kind or seed slot in `options` has `NA`), then they will
#'   be generated automatically by `JAGS`.
#'
#' @param data (`GeneralData`)\cr an input data.
#' @param model (`GeneralModel`)\cr an input model.
#' @param options (`McmcOptions`)\cr MCMC options.
#' @param ... not used.
#'
#' @return The posterior samples, an object of class [`Samples`].
#' @export
#'
setGeneric(
  name = "mcmc",
  def = function(data, model, options, ...) {
    standardGeneric("mcmc")
  },
  valueClass = "Samples"
)

# mcmc-GeneralData ----

#' @describeIn mcmc Standard method which uses JAGS.
#'
#' @param from_prior (`flag`)\cr sample from the prior only? Default to `TRUE`
#'   when number of observations in `data` is `0`. For some models it might be
#'   necessary to specify it manually here though.
#'
#' @aliases mcmc-GeneralData
#' @example examples/mcmc.R
#'
setMethod(
  f = "mcmc",
  signature = signature(
    data = "GeneralData",
    model = "GeneralModel",
    options = "McmcOptions"
  ),
  def = function(data,
                 model,
                 options,
                 from_prior = data@nObs == 0L,
                 ...) {
    assert_flag(from_prior)

    model_fun <- if (from_prior) {
      model@priormodel
    } else {
      h_jags_join_models(model@datamodel, model@priormodel)
    }

    model_file <- h_jags_write_model(model_fun)
    model_inits <- h_jags_get_model_inits(model, data)
    model_data <- h_jags_get_data(model, data, from_prior)

    jags_model <- rjags::jags.model(
      file = model_file,
      data = model_data,
      inits = c(
        model_inits,
        .RNG.name = h_null_if_na(options@rng_kind),
        .RNG.seed = h_null_if_na(options@rng_seed)
      ),
      quiet = !is_logging_enabled(),
      n.adapt = 0 # No adaptation. Important for reproducibility.
    )
    update(jags_model, n.iter = options@burnin, progress.bar = "none")

    # This is necessary as some outputs are written directly from the JAGS
    # compiled code to the outstream.
    log_trace("Running rjags::jags.samples")
    if (is_logging_enabled()) {
      jags_samples <- rjags::jags.samples(
        model = jags_model,
        variable.names = model@sample,
        n.iter = (options@iterations - options@burnin),
        thin = options@step
      )
    } else {
      invisible(
        capture.output(
          jags_samples <- rjags::jags.samples(
            model = jags_model,
            variable.names = model@sample,
            n.iter = (options@iterations - options@burnin),
            thin = options@step,
            progress.bar = "none"
          )
        )
      )
    }
    log_trace("JAGS samples: ", jags_samples, capture = TRUE)
    samples <- lapply(jags_samples, h_jags_extract_samples)

    Samples(data = samples, options = options)
  }
)

# mcmc-GeneralData-DualEndpointRW ----

#' @describeIn mcmc Standard method which uses JAGS. For the
#'   [`DualEndpointRW`] model, it is required that there are at least two (in
#'   case of random walk prior of the first order on the biomarker level) or
#'   three doses in the grid.
#'
#' @param from_prior (`flag`)\cr sample from the prior only? Default to `TRUE`
#'   when number of observations in `data` is `0`. For some models it might be
#'   necessary to specify it manually here though.
#'
#' @aliases mcmc-GeneralData-DualEndpointRW
#' @example examples/mcmc-DualEndpointRW.R
#'
setMethod(
  f = "mcmc",
  signature = signature(
    data = "GeneralData",
    model = "DualEndpointRW",
    options = "McmcOptions"
  ),
  def = function(data,
                 model,
                 options,
                 from_prior = data@nObs == 0L,
                 ...) {
    if (model@rw1) {
      assert_true(data@nGrid >= 2)
    } else {
      assert_true(data@nGrid >= 3)
    }

    callNextMethod(
      data = data,
      model = model,
      options = options,
      from_prior = from_prior,
      ...
    )
  }
)

# mcmc-GeneralData-DualEndpointBeta ----

#' @describeIn mcmc Standard method which uses JAGS. For the
#'   [`DualEndpointBeta`] model, it is required that the value of `ref_dose_beta`
#'   slot is greater than the maximum dose in a grid. This requirement comes from
#'   definition of the beta function that is used to model dose-biomarker
#'   relationship in [`DualEndpointBeta`] model. The other requirement is that
#'   there must be at least one dose in the grid.
#'
#' @param from_prior (`flag`)\cr sample from the prior only? Default to `TRUE`
#'   when number of observations in `data` is `0`. For some models it might be
#'   necessary to specify it manually here though.
#'
#' @aliases mcmc-GeneralData-DualEndpointBeta
#' @example examples/mcmc-DualEndpointBeta.R
#'
setMethod(
  f = "mcmc",
  signature = signature(
    data = "GeneralData",
    model = "DualEndpointBeta",
    options = "McmcOptions"
  ),
  def = function(data,
                 model,
                 options,
                 from_prior = data@nObs == 0L,
                 ...) {
    assert_true(data@nGrid >= 1)
    assert_true(model@ref_dose_beta > data@doseGrid[data@nGrid])

    callNextMethod(
      data = data,
      model = model,
      options = options,
      from_prior = from_prior,
      ...
    )
  }
)

# mcmc-GeneralData-DualEndpointEmax ----

#' @describeIn mcmc Standard method which uses JAGS. For the
#'   [`DualEndpointEmax`] model, it is required that there is at least one dose
#'   in the grid.
#'
#' @param from_prior (`flag`)\cr sample from the prior only? Default to `TRUE`
#'   when number of observations in `data` is `0`. For some models it might be
#'   necessary to specify it manually here though.
#'
#' @aliases mcmc-GeneralData-DualEndpointEmax
#'
setMethod(
  f = "mcmc",
  signature = signature(
    data = "GeneralData",
    model = "DualEndpointEmax",
    options = "McmcOptions"
  ),
  def = function(data,
                 model,
                 options,
                 from_prior = data@nObs == 0L,
                 ...) {
    assert_true(data@nGrid >= 1)

    callNextMethod(
      data = data,
      model = model,
      options = options,
      from_prior = from_prior,
      ...
    )
  }
)

# mcmc-GeneralData-OneParLogNormalPrior ----

#' @describeIn mcmc Standard method which uses JAGS. For the
#'   [`OneParLogNormalPrior`] model, it is required that the length of
#'   skeleton prior probabilities vector should be equal to the length of the
#'   number of doses.
#'
#' @param from_prior (`flag`)\cr sample from the prior only? Default to `TRUE`
#'   when number of observations in `data` is `0`. For some models it might be
#'   necessary to specify it manually here though.
#'
#' @aliases mcmc-GeneralData-OneParLogNormalPrior
#'
setMethod(
  f = "mcmc",
  signature = signature(
    data = "GeneralData",
    model = "OneParLogNormalPrior",
    options = "McmcOptions"
  ),
  def = function(data,
                 model,
                 options,
                 from_prior = data@nObs == 0L,
                 ...) {
    if (!from_prior) {
      assert_true(length(model@skel_probs) == data@nGrid)
    }

    callNextMethod(
      data = data,
      model = model,
      options = options,
      from_prior = from_prior,
      ...
    )
  }
)

# mcmc-GeneralData-OneParExpPrior ----

#' @describeIn mcmc Standard method which uses JAGS. For the
#'   [`OneParExpPrior`] model, it is required that the length of
#'   skeleton prior probabilities vector should be equal to the length of the
#'   number of doses.
#'
#' @param from_prior (`flag`)\cr sample from the prior only? Default to `TRUE`
#'   when number of observations in `data` is `0`. For some models it might be
#'   necessary to specify it manually here though.
#'
#' @aliases mcmc-GeneralData-OneParExpPrior
#'
setMethod(
  f = "mcmc",
  signature = signature(
    data = "GeneralData",
    model = "OneParExpPrior",
    options = "McmcOptions"
  ),
  def = function(data,
                 model,
                 options,
                 from_prior = data@nObs == 0L,
                 ...) {
    if (!from_prior) {
      assert_true(length(model@skel_probs) == data@nGrid)
    }

    callNextMethod(
      data = data,
      model = model,
      options = options,
      from_prior = from_prior,
      ...
    )
  }
)

# nolint start

## --------------------------------------------------
## The method for DataMixture usage
## --------------------------------------------------

##' @describeIn mcmc Method for DataMixture with different from_prior default
setMethod("mcmc",
  signature =
    signature(
      data = "DataMixture",
      model = "GeneralModel",
      options = "McmcOptions"
    ),
  def =
    function(data, model, options,
             from_prior = data@nObs == 0L & data@nObsshare == 0L,
             ...) {
      callNextMethod(data, model, options, from_prior = from_prior, ...)
    }
)


## --------------------------------------------------
## Replacement for BayesLogit::logit
## --------------------------------------------------

#' Do MCMC sampling for Bayesian logistic regression model
#'
#' @param y 0/1 vector of responses
#' @param X design matrix
#' @param m0 prior mean vector
#' @param P0 precision matrix
#' @param options McmcOptions object
#'
#' @importFrom rjags jags.model jags.samples
#' @return the matrix of samples (samples x parameters)
#' @keywords internal
myBayesLogit <- function(y,
                         X,
                         m0,
                         P0,
                         options) {
  ## assertions
  p <- length(m0)
  nObs <- length(y)
  stopifnot(
    is.vector(y),
    all(y %in% c(0, 1)),
    is.matrix(P0),
    identical(dim(P0), c(p, p)),
    is.matrix(X),
    identical(dim(X), c(nObs, p)),
    is(options, "McmcOptions")
  )

  ## get or set the seed
  rSeed <- try(get(".Random.seed", envir = .GlobalEnv),
    silent = TRUE
  )
  if (is(rSeed, "try-error")) {
    set.seed(floor(runif(n = 1, min = 0, max = 1e4)))
    rSeed <- get(".Random.seed", envir = .GlobalEnv)
  }
  ## .Random.seed contains two leading integers where the second
  ## gives the position in the following 624 long vector (see
  ## ?set.seed). Take the current position and ensure positivity
  rSeed <- abs(rSeed[-c(1:2)][rSeed[2]])

  ## build the model according to whether we sample from prior
  ## or not:
  bugsModel <- function() {
    for (i in 1:nObs)
    {
      y[i] ~ dbern(p[i])
      logit(p[i]) <- mu[i]
    }

    mu <- X[, ] %*% beta

    ## the multivariate normal prior on the coefficients
    beta ~ dmnorm(priorMean[], priorPrec[, ])
  }

  ## write the model file into it
  modelFileName <- h_jags_write_model(bugsModel)

  jagsModel <- rjags::jags.model(modelFileName,
    data = list(
      "X" = X,
      "y" = y,
      "nObs" = nObs,
      priorMean = m0,
      priorPrec = P0
    ),
    quiet = TRUE,
    inits =
    ## add the RNG seed to the inits list:
    ## (use Mersenne Twister as per R
    ## default)
      list(
        .RNG.name = "base::Mersenne-Twister",
        .RNG.seed = rSeed
      ),
    n.chains = 1,
    n.adapt = 0
  )
  ## burn in
  update(jagsModel,
    n.iter = options@burnin,
    progress.bar = "none"
  )

  ## samples
  samplesCode <- "samples <-
    rjags::jags.samples(model=jagsModel,
                        variable.names='beta',
                        n.iter=
                          (options@iterations - options@burnin),
                        thin=options@step,
                        progress.bar='none')"

  ## this is necessary because some outputs
  ## are written directly from the JAGS compiled
  ## code to the outstream
  capture.output(eval(parse(text = samplesCode)))

  return(t(samples$beta[, , 1L]))
}


## ----------------------------------------------------------------------------------
## Obtain posterior samples for the two-parameter logistic pseudo DLE model
## -------------------------------------------------------------------------------


##' @describeIn mcmc Obtain posterior samples for the model parameters based on the pseudo 'LogisticsIndepBeta'
##' DLE model. The joint prior and posterior probability density function of
##' the intercept \eqn{\phi_1} (phi1) and the slope \eqn{\phi_2} (phi2) are given in Whitehead and
##' Williamson (1998) and TsuTakawa (1975). However, since asymptotically, the joint posterior probability density
##' will be bivariate normal and we will use the bivariate normal distribution to
##' generate posterior samples of the intercept and the slope parameters. For the prior samples of
##' of the intercept and the slope a bivariate normal distribution with mean and the covariance matrix given in Whitehead and
##' Williamson (1998) is used.
##'
##' @importFrom mvtnorm rmvnorm
##' @example examples/mcmc-LogisticIndepBeta.R
setMethod("mcmc",
  signature =
    signature(
      data = "Data",
      model = "LogisticIndepBeta",
      options = "McmcOptions"
    ),
  def =
    function(data, model, options,
             ...) {
      ## update the DLE model first
      thismodel <- update(object = model, data = data)

      ## decide whether we sample from the prior or not
      from_prior <- data@nObs == 0L


      ## probabilities of risk of DLE at all dose levels
      pi <- (thismodel@binDLE) / (thismodel@DLEweights)
      ## scalar term for the covariance matrix
      scalarI <- thismodel@DLEweights * pi * (1 - pi)
      ##
      precision <- matrix(rep(0, 4), nrow = 2, ncol = 2)

      for (i in (1:(length(thismodel@binDLE)))) {
        precisionmat <- scalarI[i] * matrix(c(1, log(thismodel@DLEdose[i]), log(thismodel@DLEdose[i]), (log(thismodel@DLEdose[i]))^2), 2, 2)
        precision <- precision + precisionmat
      }

      if (from_prior) {
        ## sample from the (asymptotic) bivariate normal prior for theta

        tmp <- mvtnorm::rmvnorm(
          n = size(options),
          mean = c(slot(thismodel, "phi1"), slot(thismodel, "phi2")),
          sigma = solve(precision)
        )


        samples <- list(
          phi1 = tmp[, 1],
          phi2 = tmp[, 2]
        )
      } else {
        weights <- rep(1, length(data@y))
        ## probabilities of risk of DLE at all dose levels
        pi <- (data@y) / weights
        ## scalar term for the covariance matrix
        scalarI <- weights * pi * (1 - pi)
        ##

        priordle <- thismodel@binDLE
        priorw1 <- thismodel@DLEweights

        priordose <- thismodel@DLEdose
        FitDLE <- suppressWarnings(glm(priordle / priorw1 ~ log(priordose), family = binomial(link = "logit"), weights = priorw1))
        SFitDLE <- summary(FitDLE)
        ## Obtain parameter estimates for dose-DLE curve
        priorphi1 <- coef(SFitDLE)[1, 1]
        priorphi2 <- coef(SFitDLE)[2, 1]

        ## use fast special sampler here
        ## set up design matrix
        X <- cbind(1, log(data@x))
        initRes <- myBayesLogit(
          y = data@y,
          X = X,
          m0 = c(priorphi1, priorphi2),
          P0 = precision,
          options = options
        )

        ## then form the samples list
        samples <- list(
          phi1 = initRes[, 1],
          phi2 = initRes[, 2]
        )
      }

      ## form a Samples object for return:
      ret <- Samples(
        data = samples,
        options = options
      )

      return(ret)
    }
)

## ================================================================================

## -----------------------------------------------------------------------------------
## obtain the posterior samples for the Pseudo Efficacy log log model
## ----------------------------------------------------------------------------
##
##' @describeIn mcmc Obtain the posterior samples for the model parameters in the
##' Efficacy log log model. Given the value of \eqn{\nu}, the precision of the efficacy responses,
##' the joint prior or the posterior probability of the intercept \eqn{\theta_1} (theta1) and
##' the slope \eqn{\theta_2} (theta2) is a bivariate normal distribution. The  \eqn{\nu} (nu),
##' the precision of the efficacy responses is either a fixed value or has a gamma distribution.
##' If a gamma distribution is used, the samples of nu will be first generated.
##' Then the mean of the of the nu samples
##' will be used the generate samples of the intercept and slope parameters of the model
##' @example examples/mcmc-Effloglog.R
##' @importFrom mvtnorm rmvnorm
setMethod(
  f = "mcmc",
  signature = signature(
    data = "DataDual",
    model = "Effloglog",
    options = "McmcOptions"
  ),
  definition = function(data, model, options, ...) {
    model <- update(object = model, data = data)
    sample_size <- size(options)

    if (model@use_fixed) {
      nu <- model@nu
      nu_samples <- rep(nu, sample_size)
    } else {
      nu_samples <- rgamma(sample_size, shape = model@nu["a"], rate = model@nu["b"])
      nu <- mean(nu_samples)
    }

    # Sample from the (asymptotic) bivariate normal prior for theta1 and theta2.
    tmp <- mvtnorm::rmvnorm(
      n = sample_size,
      mean = model@mu,
      sigma = solve(nu * model@Q)
    )

    samples <- list(
      theta1 = tmp[, 1],
      theta2 = tmp[, 2],
      nu = nu_samples
    )

    Samples(
      data = samples,
      options = options
    )
  }
)
## ======================================================================================
## -----------------------------------------------------------------------------------
## obtain the posterior samples for the Pseudo Efficacy Flexible form
## ----------------------------------------------------------------------------
##
##' @describeIn mcmc Obtain the posterior samples for the estimates in the Efficacy Flexible form.
##' This is the mcmc procedure based on what is described in Lang and Brezger (2004) such that
##' samples of the mean efficacy responses at all dose levels, samples of sigma2 \eqn{sigma^2},
##' the variance of the efficacy response and samples of sigma2betaW \eqn{sigma^2_{beta_W}}, the variance of
##' the random walk model will
##' be generated. Please refer to Lang and Brezger (2004) for the procedures and the form of
##' the joint prior and posterior probability density for the mean efficacy responses. In addition,
##' both sigma2 and sigma2betaW can be fixed or having an inverse-gamma prior and posterior distribution.
##' Therefore, if the inverse gamma distribution(s) are used, the parameters in the distribution will be
##' first updated and then samples of sigma2 and sigma2betaW will be generated using the updated parameters.
##' @example examples/mcmc-EffFlexi.R
setMethod("mcmc",
  signature =
    signature(
      data = "DataDual",
      model = "EffFlexi",
      options = "McmcOptions"
    ),
  def =
    function(data, model, options,
             ...) {
      ## update the model
      thismodel <- update(object = model, data = data)

      nSamples <- size(options)

      ## Prepare samples container
      ### List parameter samples to save
      samples <- list(
        ExpEff = matrix(ncol = data@nGrid, nrow = nSamples),
        sigma2W = matrix(nrow = nSamples),
        sigma2betaW = matrix(nrow = nSamples)
      )
      ## Prepare starting values
      ## Index of the next sample to be saved:

      iterSave <- 1L
      ## Monitoring the Metropolis-Hastings update for sigma2

      acceptHistory <- list(sigma2W = logical(options@iterations))

      ## Current parameter values and also the starting values for the MCMC are set
      ## EstEff: constant, the average of the observed efficacy values

      if (length(data@w) == 0) {
        w1 <- thismodel@eff
        x1 <- thismodel@eff_dose
      } else {
        ## Combine pseudo data with observed efficacy responses and no DLT observed
        eff_obsrv <- getEff(data, no_dlt = TRUE)
        w1 <- c(thismodel@eff, eff_obsrv$w_no_dlt)
        x1 <- c(thismodel@eff_dose, eff_obsrv$x_no_dlt)
      }
      x1Level <- match_within_tolerance(x1, data@doseGrid)
      ## betaW is constant, the average of the efficacy values
      betaW <- rep(mean(w1), data@nGrid)
      ## sigma2betaW use fixed value or prior mean
      sigma2betaW <-
        if (thismodel@use_fixed[["sigma2betaW"]]) {
          thismodel@sigma2betaW
        } else {
          thismodel@sigma2betaW["b"] / (thismodel@sigma2betaW["a"] - 1)
        }
      ## sigma2: fixed value or just the empirical variance
      sigma2W <- if (thismodel@use_fixed[["sigma2W"]]) {
        thismodel@sigma2W
      } else {
        var(w1)
      }
      ## Set up diagonal matrix with the number of patients in the corresponding dose levels on the diagonal
      designWcrossprod <- crossprod(thismodel@X)

      ### The MCMC cycle

      for (iterMcmc in seq_len(options@iterations))
      { ## 1) Generate coefficients for the Flexible Efficacy model
        ## the variance
        adjustedVar <- sigma2W
        ## New precision matrix
        thisPrecW <- designWcrossprod / adjustedVar + thismodel@RW / sigma2betaW
        ## draw random normal vector
        normVec <- rnorm(data@nGrid)
        ## and its Cholesky factor
        thisPrecWchol <- chol(thisPrecW)
        ## solve betaW for L^T * betaW = normVec
        betaW <- backsolve(r = thisPrecWchol, x = normVec)
        ## the residual
        adjustedW <- w1 - thismodel@X %*% betaW

        ## forward substitution
        ## solve L^T * tmp = designW ^T * adjustedW/ adjustedVar

        tmp <- forwardsolve(
          l = thisPrecWchol,
          x = crossprod(thismodel@X, adjustedW) / adjustedVar,
          upper.tri = TRUE,
          transpose = TRUE
        )
        ## Backward substitution solve R*tepNew =tmp
        tmp <- backsolve(
          r = thisPrecWchol,
          x = tmp
        )

        ## tmp is the mean vector of the distribution
        ## add tmp to betaW to obtain final sample

        betaW <- betaW + tmp

        ## 2) Generate prior variance factor for the random walk
        ## if fixed, do nothing
        ## Otherwise sample from full condition

        if (!thismodel@use_fixed[["sigma2betaW"]]) {
          sigma2betaW <- rinvGamma(
            n = 1L,
            a = thismodel@sigma2betaW["a"] + thismodel@RW_rank / 2,
            b = thismodel@sigma2betaW["b"] + crossprod(betaW, thismodel@RW %*% betaW) / 2
          )
        }
        ## 3) Generate variance for the flexible efficacy model
        ## if fixed variance is used
        if (thismodel@use_fixed[["sigma2W"]]) { ## do nothing
          acceptHistory$sigma2W[iterMcmc] <- TRUE
        } else {
          ## Metropolis-Hastings update step here, using
          ## an inverse gamma distribution
          aStar <- thismodel@sigma2W["a"] + length(x1) / 2
          ## Second parameter bStar depends on the value for sigma2W
          bStar <- function(x) {
            adjW <- w1
            ret <- sum((adjW - betaW[x1Level])^2) / 2 + thismodel@sigma2W["b"]
            return(ret)
          }
          ### Draw proposal:
          bStarProposal <- bStar(sigma2W)
          sigma2W <- rinvGamma(n = 1L, a = aStar, b = bStarProposal)
        }


        ## 4)Save Samples

        if (saveSample(options, iterMcmc)) {
          samples$ExpEff[iterSave, ] <- betaW
          samples$sigma2W[iterSave, 1] <- sigma2W
          samples$sigma2betaW[iterSave, 1] <- sigma2betaW
          iterSave <- iterSave + 1L
        }
      }


      ret <- Samples(
        data = samples,
        options = options
      )
      return(ret)
    }
)
# nolint end

## -----------------------------------------------------------------------------------
## obtain the posterior samples for ordinal models
## ----------------------------------------------------------------------------
##
##' @describeIn mcmc Obtain the posterior samples for the model parameters in the
##' `LogisticLogNormalOrdinal`.
##'
##' The generic `mcmc` method returns a `Samples` object with elements of the
##' `data` slot named `alpha[1]`, `alpha[2]`, ..., `alpha[k]` and `beta` when
##' passed a `LogisticLogNormalOrdinal` object.  This makes the "alpha elements"
##' awkward to access and is inconsistent with other `Model` objects.  So rename
##' the alpha elements to `alpha1`, `alpha2`, ..., `alpha<k>` for ease and
##' consistency.
##'
##' @example examples/mcmc-LogisticLogNormalOrdinal.R
setMethod(
  f = "mcmc",
  signature = signature(
    data = "DataOrdinal",
    model = "LogisticLogNormalOrdinal",
    options = "McmcOptions"
  ),
  definition = function(data, model, options, ...) {
    # Obtain samples using the default method, but ...
    return_value <- callNextMethod()
    # ... rename the alpha elements from alpha[<k>] to alpha<k>, where <k> is an
    # integer
    names(return_value@data) <- gsub("\\[(\\d+)\\]", "\\1", names(return_value@data))
    return_value
  }
)

#' Internal Helper Functions for Validation of [`GeneralData`] Objects
#'
#' @description `r lifecycle::badge("stable")`
#'
#' These functions are only used internally to validate the format of an input
#' [`GeneralData`] or inherited classes and therefore not exported.
#'
#' @name v_data_objects
#' @param object (`GeneralData`)\cr object to validate.
#' @return A `character` vector with the validation failure messages,
#'   or `TRUE` in case validation passes.
NULL

#' @describeIn v_data_objects validates that the [`GeneralData`]
#'   object contains unique `ID`, non-negative `cohort` indices and
#'   `ID` and `cohort` vectors are of the same length `nObs`.
v_general_data <- function(object) {
  v <- Validate()
  # In if clause so that below test_* won't fail.
  if (!test_int(object@nObs)) {
    return("nObs must be of type integer of length 1")
  }
  v$check(
    test_integer(object@ID, len = object@nObs, any.missing = FALSE, unique = TRUE, null.ok = TRUE),
    "ID must be of type integer and length nObs and unique"
  )
  v$check(
    test_integer(object@cohort, lower = 0L, len = object@nObs, any.missing = FALSE, sorted = TRUE),
    "cohort must be of type integer and length nObs and contain non-negative, sorted values"
  )
  v$result()
}

#' @describeIn v_data_objects helper function which verifies whether
#'   the `dose` values are unique in each and every different `cohort`.
#' @param dose (`numeric`)\cr dose values.
#' @param cohort (`integer`)\cr cohort indices parallel to `doses`.
#' @return `TRUE` if `dose` is unique per `cohort`, otherwise `FALSE`.
h_doses_unique_per_cohort <- function(dose, cohort) {
  assert_numeric(dose)
  assert_integer(cohort)

  num_doses_per_cohort <- tapply(
    X = dose,
    INDEX = cohort,
    FUN = function(d) length(unique(d))
  )
  all(num_doses_per_cohort == 1L)
}

#' Helper Function performing validation Common to Data and DataOrdinal
#'
#' @rdname h_validate_common_data_slots
#' @param object (`Data` or `DataOrdinal`)\cr the object to be validated
#' @returns a `Validate` object containing the result of the validation
h_validate_common_data_slots <- function(object) {
  v <- Validate()
  v$check(
    test_double(object@x, len = object@nObs, any.missing = FALSE),
    "Doses vector x must be of type double and length nObs"
  )
  v$check(
    test_double(object@doseGrid, len = object@nGrid, any.missing = FALSE, unique = TRUE, sorted = TRUE),
    "doseGrid must be of type double and length nGrid and contain unique, sorted values"
  )
  v$check(
    test_int(object@nGrid),
    "Number of dose grid values nGrid must be scalar integer"
  )
  v$check(
    test_integer(object@xLevel, len = object@nObs, any.missing = FALSE),
    "Levels xLevel for the doses the patients have been given must be of type integer and length nObs"
  )
  v$check(
    test_flag(object@placebo),
    "The placebo flag must be scalar logical"
  )
  v$check(
    test_subset(object@x, object@doseGrid),
    "Dose values in x must be from doseGrid"
  )
  v$check(
    h_all_equivalent(object@x, object@doseGrid[object@xLevel]),
    "x must be equivalent to doseGrid[xLevel] (up to numerical tolerance)"
  )
  if (object@placebo) {
    is_placebo <- object@x == object@doseGrid[1]
    v$check(
      test_set_equal(object@cohort, object@cohort[!is_placebo]),
      "A cohort with only placebo is not allowed"
    )
    v$check(
      h_doses_unique_per_cohort(dose = object@x[!is_placebo], cohort = object@cohort[!is_placebo]),
      "There must be only one dose level, other than placebo, per cohort"
    )
  } else {
    v$check(
      h_doses_unique_per_cohort(dose = object@x, cohort = object@cohort),
      "There must be only one dose level per cohort"
    )
  }
  v
}

#' @describeIn v_data_objects validates that the [`Data`] object contains
#'   valid elements with respect to their types, dependency and length.
v_data <- function(object) {
  v <- h_validate_common_data_slots(object)
  v$check(
    test_integer(object@y, lower = 0, upper = 1, len = object@nObs, any.missing = FALSE),
    "DLT vector y must be nObs long and contain 0 or 1 integers only"
  )

  v$result()
}

#' @describeIn v_data_objects validates that the [`DataDual`] object
#' contains valid biomarker vector with respect to its type and the length.
v_data_dual <- function(object) {
  v <- Validate()
  v$check(
    test_double(object@w, len = object@nObs, any.missing = FALSE),
    "Biomarker vector w must be of type double and length nObs"
  )
  v$result()
}

#' @describeIn v_data_objects validates that the [`DataParts`] object
#' contains valid elements with respect to their types, dependency and length.
v_data_parts <- function(object) {
  v <- Validate()
  v$check(
    test_integer(object@part, lower = 1, upper = 2, len = object@nObs, any.missing = FALSE),
    "vector part must be nObs long and contain 1 or 2 integers only"
  )
  v$check(
    test_int(object@nextPart, lower = 1, upper = 2),
    "nextPart must be integer scalar 1 or 2"
  )
  v$check(
    test_numeric(object@part1Ladder, any.missing = FALSE, sorted = TRUE, unique = TRUE),
    "part1Ladder must be of type double and contain unique, sorted values"
  )
  v$check(
    test_subset(object@part1Ladder, object@doseGrid),
    "part1Ladder must have all entries from doseGrid"
  )
  v$result()
}

#' @describeIn v_data_objects validates that the [`DataMixture`] object
#' contains valid elements with respect to their types, dependency and length.
v_data_mixture <- function(object) {
  v <- Validate()

  # In if clause so that below test_* won't fail.
  if (!test_int(object@nObsshare)) {
    return("nObsshare must be of type integer of length 1")
  }
  v$check(
    test_numeric(object@xshare, len = object@nObsshare, any.missing = FALSE),
    "Dose vector xshare must be of type double and length nObsshare"
  )
  v$check(
    test_integer(object@yshare, lower = 0, upper = 1, len = object@nObsshare, any.missing = FALSE),
    "DLT vector yshare must be nObsshare long and contain 0 or 1 integers only"
  )
  v$check(
    test_subset(object@xshare, object@doseGrid),
    "Dose values in xshare must be from doseGrid"
  )
  v$result()
}

#' @describeIn v_data_objects validates that the [`DataDA`] object
#' contains valid elements with respect to their types, dependency and length.
v_data_da <- function(object) {
  v <- Validate()
  # In if clause so that below test_* won't fail.
  if (!(test_number(object@Tmax) && object@Tmax > 0)) {
    return("DLT window Tmax must be of type double of length 1 and greater than 0")
  }
  v$check(
    test_numeric(object@u, upper = object@Tmax, len = object@nObs, any.missing = FALSE) &&
      all(object@u > 0),
    "u must be of type double, nObs length, non-negative and not greater than Tmax"
  )
  v$check(
    test_numeric(object@t0, lower = 0, len = object@nObs, any.missing = FALSE, sorted = TRUE),
    "t0 must be of type double, nObs length, sorted non-negative"
  )
  v$result()
}

#' @describeIn v_data_objects validates that the [`DataOrdinal`] object
#' contains valid elements with respect to their types, dependency and length.
v_data_ordinal <- function(object) {
  v <- h_validate_common_data_slots(object)
  v$check(
    test_integer(object@y, lower = 0, upper = length(object@yCategories) - 1, len = object@nObs, any.missing = FALSE),
    "DLT vector y must be nObs long and contain integers between 0 and k-1 only, where k is the length of the vector in the yCategories slot" # nolint
  )
  v$check(
    length(unique(names(object@yCategories))) == length(names(object@yCategories)),
    "yCategory labels must be unique"
  )
  v$result()
}

#' @describeIn v_data_objects validates that the [`DataGrouped`] object
#'   contains valid group information.
v_data_grouped <- function(object) {
  v <- Validate()
  v$check(
    test_factor(
      object@group,
      levels = c("mono", "combo"),
      len = object@nObs,
      any.missing = FALSE
    ),
    "group must be factor with levels mono and combo of length nObs without missings"
  )
  v$result()
}

#' @include helpers.R
#' @include Data-class.R
#' @include Simulations-validity.R
#' @include CrmPackClass-class.R
NULL

# GeneralSimulations ----

## class ----

#' `GeneralSimulations`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' This class captures trial simulations.
#' Here also the random generator state before starting the simulation is
#' saved, in order to be able to reproduce the outcome. For this just use
#' [`set.seed`] with the `seed` as argument before running
#' [`simulate,Design-method`].
#'
#' @slot data (`list`)\cr produced [`Data`] objects.
#' @slot doses (`numeric`)\cr final dose recommendations.
#' @slot seed (`integer`)\cr random generator state before starting the simulation.
#'
#' @aliases GeneralSimulations
#' @export
.GeneralSimulations <-
  setClass(
    Class = "GeneralSimulations",
    slots = c(
      data = "list",
      doses = "numeric",
      seed = "integer"
    ),
    prototype = prototype(
      data =
        list(
          Data(
            x = 1:2,
            y = 0:1,
            doseGrid = 1:2,
            ID = 1L:2L,
            cohort = 1L:2L
          ),
          Data(
            x = 3:4,
            y = 0:1,
            doseGrid = 3:4,
            ID = 1L:2L,
            cohort = 1L:2L
          )
        ),
      doses = c(1, 2),
      seed = 1L
    ),
    contains = "CrmPackClass",
    validity = v_general_simulations
  )

## constructor ----

#' @rdname GeneralSimulations-class
#'
#' @param data (`list`)\cr see slot definition.
#' @param doses (`numeric`)\cr see slot definition.
#' @param seed (`integer`)\cr see slot definition.
#'
#' @example examples/Simulations-class-GeneralSimulations.R
#' @export
GeneralSimulations <- function(data,
                               doses,
                               seed) {
  assert_integerish(seed)
  .GeneralSimulations(
    data = data,
    doses = doses,
    seed = as.integer(seed)
  )
}


## default constructor

#' @rdname GeneralSimulations-class
#' @note Typically, end users will not use the `.DefaultGeneralSimulations()` function.
#' @export
.DefaultGeneralSimulations <- function() {
  GeneralSimulations(
    data = list(
      Data(x = 1:3, y = c(0, 1, 0), doseGrid = 1:3, ID = 1L:3L, cohort = 1L:3L),
      Data(x = 4:6, y = c(0, 1, 0), doseGrid = 4:6, ID = 1L:3L, cohort = 1L:3L)
    ),
    doses = c(1, 2),
    seed = 123
  )
}


# Simulations ----

## class ----

#' `Simulations`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' This class captures the trial simulations from model based designs.
#' Additional slots `fit`, `stop_reasons`, `stop_report`,`additional_stats` compared to
#' the general class [`GeneralSimulations`].
#'
#' @slot fit (`list`)\cr final fits
#' @slot stop_reasons (`list`)\cr stopping reasons for each simulation run
#' @slot stop_report matrix of stopping rule outcomes
#' @slot additional_stats list of additional statistical summary
#' @aliases Simulations
#' @export
.Simulations <-
  setClass(
    Class = "Simulations",
    slots = c(
      fit = "list",
      stop_report = "matrix",
      stop_reasons = "list",
      additional_stats = "list"
    ),
    prototype = prototype(
      fit =
        list(
          c(0.1, 0.2),
          c(0.1, 0.2)
        ),
      stop_report = matrix(TRUE, nrow = 2),
      stop_reasons =
        list("A", "A"),
      additional_stats =
        list(a = 1, b = 1)
    ),
    contains = "GeneralSimulations",
    validity = v_simulations
  )

## constructor ----

#' @rdname Simulations-class
#'
#' @param fit (`list`)\cr see slot definition.
#' @param stop_reasons (`list`)\cr see slot definition.
#' @param stop_report see [`Simulations`]
#' @param additional_stats (`list`)\cr see slot definition.
#' @param \dots additional parameters from [`GeneralSimulations`]
#'
#' @example examples/Simulations-class-Simulations.R
#' @export
Simulations <- function(fit,
                        stop_reasons,
                        stop_report,
                        additional_stats,
                        ...) {
  start <- GeneralSimulations(...)
  .Simulations(start,
    fit = fit,
    stop_report = stop_report,
    stop_reasons = stop_reasons,
    additional_stats = additional_stats
  )
}

## default constructor ----

#' @rdname Simulations-class
#' @note Typically, end users will not use the `.DefaultSimulations()` function.
#' @export
.DefaultSimulations <- function() {
  design <- .DefaultDesign()
  myTruth <- probFunction(design@model, alpha0 = 7, alpha1 = 8)

  simulate(
    design,
    args = NULL,
    truth = myTruth,
    nsim = 1,
    seed = 819,
    mcmcOptions = .DefaultMcmcOptions(),
    parallel = FALSE
  )
}

# DualSimulations ----

## class ----

#' `DualSimulations`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' This class captures the trial simulations from dual-endpoint model based
#' designs. In comparison to the parent class [`Simulations`],
#' it contains additional slots to capture the dose-biomarker `fits`, and the
#' `sigma2W` and `rho` estimates.
#'
#' @slot rho_est (`numeric`)\cr vector of final posterior median rho estimates
#' @slot sigma2w_est (`numeric`)\cr vector of final posterior median sigma2W estimates
#' @slot fit_biomarker (`list`)\cr with the final dose-biomarker curve fits
#' @aliases DualSimulations
#' @export
.DualSimulations <-
  setClass(
    Class = "DualSimulations",
    slots = c(
      rho_est = "numeric",
      sigma2w_est = "numeric",
      fit_biomarker = "list"
    ),
    prototype = prototype(
      rho_est = c(0.2, 0.3),
      sigma2w_est = c(0.2, 0.3),
      fit_biomarker =
        list(
          c(0.1, 0.2),
          c(0.1, 0.2)
        )
    ),
    contains = "Simulations",
    validity = v_dual_simulations
  )


## constructor ----

#' @rdname DualSimulations-class
#'
#' @param rho_est (`numeric`)\cr see [`DualSimulations`]
#' @param sigma2w_est (`numeric`)\cr [`DualSimulations`]
#' @param fit_biomarker (`list`)\cr see [`DualSimulations`]
#' @param \dots additional parameters from [`Simulations`]
#'
#' @example examples/Simulations-class-DualSimulations.R
#' @export
DualSimulations <- function(rho_est,
                            sigma2w_est,
                            fit_biomarker,
                            ...) {
  start <- Simulations(...)
  .DualSimulations(start,
    rho_est = rho_est,
    sigma2w_est = sigma2w_est,
    fit_biomarker = fit_biomarker
  )
}

## default constructor ----

#' @rdname DualSimulations-class
#' @note Typically, end users will not use the `.DefaultDualSimulations()` function.
#' @export
.DefaultDualSimulations <- function() {
  DualSimulations(
    rho_est = c(0.25, 0.35),
    sigma2w_est = c(0.15, 0.25),
    fit_biomarker = list(c(0.3, 0.4), c(0.4, 0.5)),
    fit = list(
      c(0.1, 0.2),
      c(0.3, 0.4)
    ),
    stop_report = matrix(c(TRUE, FALSE), nrow = 2),
    stop_reasons = list("A", "B"),
    additional_stats = list(a = 1, b = 1),
    data = list(
      Data(
        x = 1:2,
        y = 0:1,
        doseGrid = 1:2,
        ID = 1L:2L,
        cohort = 1L:2L
      ),
      Data(
        x = 3:4,
        y = 0:1,
        doseGrid = 3:4,
        ID = 1L:2L,
        cohort = 1L:2L
      )
    ),
    doses = c(1, 2),
    seed = 123L
  )
}

#' `GeneralSimulationsSummary`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' This class captures the summary of general simulations output. Note that objects
#' should not be created by users, therefore no initialization
#' function is provided for this class.
#'
#' @slot target (`numeric`)\cr target toxicity interval
#' @slot target_dose_interval (`numeric`)\cr corresponding target dose interval
#' @slot nsim (`integer`)\cr number of simulations
#' @slot prop_dlts (`ANY`)\cr A numeric array (multi-dimensional) or list representing proportions of DLTs in the trials
#' @slot mean_tox_risk (`numeric`)\cr mean toxicity risks for the patients
#' @slot dose_selected (`numeric`)\cr doses selected as MTD
#' @slot tox_at_doses_selected (`numeric`)\cr true toxicity at doses selected
#' @slot prop_at_target (`numeric`)\cr Proportion of trials selecting target MTD
#' @slot dose_most_selected (`numeric`)\cr dose most often selected as MTD
#' @slot obs_tox_rate_at_dose_most_selected (`numeric`)\cr observed toxicity rate at dose most often selected
#' @slot n_obs (`ANY`)\cr A numeric array (multi-dimensional) or list representing number of patients overall.
#' @slot n_above_target (`integer`)\cr number of patients treated above target tox interval
#' @slot dose_grid (`numeric`)\cr the dose grid that has been used
#' @slot placebo (`logical`)\cr set to TRUE (default is FALSE) for a design with placebo
#' @aliases GeneralSimulationsSummary
#' @export
.GeneralSimulationsSummary <-
  setClass(
    Class = "GeneralSimulationsSummary",
    slots = c(
      target = "numeric",
      target_dose_interval = "numeric",
      nsim = "integer",
      prop_dlts = "ANY",
      mean_tox_risk = "numeric",
      dose_selected = "numeric",
      tox_at_doses_selected = "numeric",
      prop_at_target = "numeric",
      dose_most_selected = "numeric",
      obs_tox_rate_at_dose_most_selected = "numeric",
      n_obs = "ANY",
      n_above_target = "integer",
      dose_grid = "numeric",
      placebo = "logical"
    )
  )

## default constructor ----

#' @rdname GeneralSimulationsSummary-class
#' @note Typically, end users will not use the `.DefaultGeneralSimulationsSummary()` function.
#' @export
.DefaultGeneralSimulationsSummary <- function() {
  stop(
    paste(
      "Class GeneralSimulationsSummary cannot be instantiated directly.",
      "Please use one of its subclasses instead."
    )
  )
}

## SimulationsSummary ----

## class ----

#' `SimulationsSummary`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' In addition to the slots in the parent class [`GeneralSimulationsSummary`],
#' it contains two slots with model fit information.
#'
#' @slot stop_report (`matrix`)\cr matrix of stopping rule outcomes
#' @slot fit_at_dose_most_selected (`numeric`)\cr fitted toxicity rate at dose most often selected
#' @slot additional_stats (`list`)\cr list of additional statistical summary
#' @slot mean_fit (`list`)\cr list with the average, lower (2.5%) and upper (97.5%)
#' quantiles of the mean fitted toxicity at each dose level
#'
#' @aliases SimulationsSummary
#' @export
.SimulationsSummary <-
  setClass(
    Class = "SimulationsSummary",
    slots = c(
      stop_report = "matrix",
      fit_at_dose_most_selected = "numeric",
      additional_stats = "list",
      mean_fit = "list"
    ),
    contains = "GeneralSimulationsSummary"
  )

## default constructor ----

#' @rdname SimulationsSummary-class
#' @note Typically, end users will not use the `.DefaultSimulationsSummary()` function.
#' @export
.DefaultSimulationsSummary <- function() {
  stop(paste(
    "Class SimulationsSummary cannot be instantiated directly.",
    "Please use one of its subclasses instead."
  ))
}

# nolint start
# DualSimulationsSummary ----

##' Class for the summary of dual-endpoint simulations output
##'
##' In addition to the slots in the parent class
##' \code{\linkS4class{SimulationsSummary}}, it contains two slots for the
##' biomarker model fit information.
##'
##' Note that objects should not be created by users, therefore no
##' initialization function is provided for this class.
##'
##' @slot biomarkerFitAtDoseMostSelected fitted biomarker level at dose most often selected
##' @slot meanBiomarkerFit list with the average, lower (2.5%) and upper (97.5%)
##' quantiles of the mean fitted biomarker level at each dose level
##'
##' @export
##' @keywords classes
.DualSimulationsSummary <-
  setClass(
    Class = "DualSimulationsSummary",
    contains = "SimulationsSummary",
    representation =
      representation(
        biomarkerFitAtDoseMostSelected = "numeric",
        meanBiomarkerFit = "list"
      )
  )

## default constructor ----

#' @rdname DualSimulationsSummary-class
#' @note Typically, end users will not use the `.DefaultDualSimulationsSummary()` function.
#' @export
.DefaultDualSimulationsSummary <- function() {
  emptydata <- DataDual(doseGrid = c(1, 3, 5, 10, 15, 20, 25, 30))

  # Initialize the CRM model.
  my_model <- DualEndpointRW(
    mean = c(0, 1),
    cov = matrix(c(1, 0, 0, 1), nrow = 2),
    sigma2betaW = 0.01,
    sigma2W = c(a = 0.1, b = 0.1),
    rho = c(a = 1, b = 1),
    rw1 = TRUE
  )

  # Choose the rule for selecting the next dose.
  my_next_best <- NextBestDualEndpoint(
    target = c(0.9, 1),
    overdose = c(0.35, 1),
    max_overdose_prob = 0.25
  )

  # Choose the rule for the cohort-size.
  my_size1 <- CohortSizeRange(
    intervals = c(0, 30),
    cohort_size = c(1, 3)
  )
  my_size2 <- CohortSizeDLT(
    intervals = c(0, 1),
    cohort_size = c(1, 3)
  )
  my_size <- maxSize(my_size1, my_size2)

  # Choose the rule for stopping.
  my_stopping1 <- StoppingTargetBiomarker(
    target = c(0.9, 1),
    prob = 0.5
  )

  # Stop with a small number of patients for illustration.
  my_stopping <- my_stopping1 | StoppingMinPatients(10) | StoppingMissingDose()

  # Choose the rule for dose increments.
  my_increments <- IncrementsRelative(
    intervals = c(0, 20),
    increments = c(1, 0.33)
  )

  # Initialize the design.
  my_design <- DualDesign(
    model = my_model,
    data = emptydata,
    nextBest = my_next_best,
    stopping = my_stopping,
    increments = my_increments,
    cohort_size = CohortSizeConst(3),
    startingDose = 3
  )

  # Define scenarios for the TRUE toxicity and efficacy profiles.
  beta_mod <- function(dose, e0, eMax, delta1, delta2, scal) {
    maxDens <- (delta1^delta1) * (delta2^delta2) / ((delta1 + delta2)^(delta1 + delta2))
    dose <- dose / scal
    e0 + eMax / maxDens * (dose^delta1) * (1 - dose)^delta2
  }

  true_biomarker <- function(dose) {
    beta_mod(dose, e0 = 0.2, eMax = 0.6, delta1 = 5, delta2 = 5 * 0.5 / 0.5, scal = 100)
  }

  true_tox <- function(dose) {
    pnorm((dose - 60) / 10)
  }

  # Run the simulation on the desired design.
  # For illustration purposes only 1 trial outcome is generated and 5 burn-ins
  # to generate 20 samples are used here.
  x <- simulate(
    object = my_design,
    trueTox = true_tox,
    trueBiomarker = true_biomarker,
    sigma2W = 0.01,
    rho = 0,
    nsim = 1,
    parallel = FALSE,
    seed = 3,
    startingDose = 6,
    mcmcOptions = .DefaultMcmcOptions()
  )
}


## ==============================================================================

## -------------------------------------------------------------------------------
## class for simulation using pseudo models
## ------------------------------------------------------------------------

##' Class `PseudoSimulations`
##'
##' This is a class which captures the trial simulations from designs using
##' pseudo model. The design for DLE only responses and model from \code{\linkS4class{ModelTox}}
##' class object. It contains all slots from \code{\linkS4class{GeneralSimulations}} object.
##' Additional slots fit and stopReasons compared to the general class
##' \code{\linkS4class{GeneralSimulations}}.
##'
##' @slot fit list of the final values. If samples are involved, these are the final fitted values.
##' If no samples are involved, these are included the final modal estimates of the model parameters
##' and the posterior estimates of the probabilities of the occurrence of a DLE.
##' @slot FinalTDtargetDuringTrialEstimates the vector of all final estimates (the last estimate of) the TDtargetDuringTrial at the end
##' of each simulations/when each trial stops
##' @slot FinalTDtargetEndOfTrialEstimates vector of all final estimates or the last estimate of the TDtargetEndOfTrial when each trial
##' stops
##' @slot FinalTDtargetDuringTrialAtDoseGrid vector of the dose levels at dose grid closest below the final TDtargetDuringTrial estimates
##' @slot FinalTDtargetEndOfTrialAtDoseGrid vector of  the dose levels at dose grid closest below the final TDtargetEndOfTrial estimates
##' @slot FinalTDEOTCIs is the list of all 95% credibility interval of the final estimates of the TDtargetEndOfTrial
##' @slot FinalTDEOTRatios is the vector of the ratios of the CI, the ratio of the upper to the lower 95% credibility intervals
##' of the final estimates of the TDtargetEndOfTrial
##' @slot FinalCIs list of all the final 95% credibility intervals of the TDtargetEndofTrial estimates or of the final optimal dose
##' estimates when DLE and efficacy responses are incorporated after each simulations
##' @slot FinalRatios vector of all the final ratios, the ratios of the upper to the lower 95% credibility interval of the
##' final estimates of the TDtargetEndOfTrial or of the final optimal dose estimates (when DLE and efficacy responses are
##' incorporated) after each simulations
##' @slot stopReasons add slot description
##' @slot stop_report matrix of stopping rule outcomes
##'
##' @export
.PseudoSimulations <-
  setClass(
    Class = "PseudoSimulations",
    representation(
      fit = "list",
      FinalTDtargetDuringTrialEstimates = "numeric",
      FinalTDtargetEndOfTrialEstimates = "numeric",
      FinalTDtargetDuringTrialAtDoseGrid = "numeric",
      FinalTDtargetEndOfTrialAtDoseGrid = "numeric",
      FinalTDEOTCIs = "list",
      FinalTDEOTRatios = "numeric",
      FinalCIs = "list",
      FinalRatios = "numeric",
      stop_report = "matrix",
      stopReasons = "list"
    ),
    ## note: this prototype is put together with the prototype
    ## for GeneralSimulations
    prototype(
      FinalTDtargetDuringTrialEstimates = c(0.1, 0.1),
      FinalTDtargetEndOfTrialEstimates = c(0.1, 0.1),
      FinalTDtargetDuringTrialAtDoseGrid = c(0.1, 0.1),
      FinalTDtargetEndOfTrialAtDoseGrid = c(0.1, 0.1),
      FinalTDEOTCIs = list(c(0.1, 0.2), c(0.1, 0.2)),
      FinalTDEOTRatios = c(0.1, 0.1),
      FinalCIs = list(c(0.1, 0.2), c(0.1, 0.2)),
      FinalRatios = c(0.1, 0.1),
      stop_report = matrix(TRUE, nrow = 2),
      stopReasons =
        list("A", "A")
    ),
    contains = "GeneralSimulations",
    validity = v_pseudo_simulations
  )
validObject(.PseudoSimulations())

##' Initialization function of the 'PseudoSimulations' class
##' @param fit please refer to \code{\linkS4class{PseudoSimulations}} class object
##' @param FinalTDtargetDuringTrialEstimates please refer to \code{\linkS4class{PseudoSimulations}} class object
##' @param FinalTDtargetEndOfTrialEstimates please refer to \code{\linkS4class{PseudoSimulations}} class object
##' @param FinalTDtargetDuringTrialAtDoseGrid please refer to \code{\linkS4class{PseudoSimulations}} class object
##' @param FinalTDtargetEndOfTrialAtDoseGrid please refer to \code{\linkS4class{PseudoSimulations}} class object
##' @param FinalTDEOTCIs please refer to \code{\linkS4class{PseudoSimulations}} class object
##' @param FinalTDEOTRatios please refer to \code{\linkS4class{PseudoSimulations}} class object
##' @param FinalCIs please refer to \code{\linkS4class{PseudoSimulations}} class object
##' @param FinalRatios please refer to \code{\linkS4class{PseudoSimulations}} class object
##' @param stopReasons please refer to \code{\linkS4class{PseudoSimulations}} class object
##' @param stop_report see [`PseudoSimulations`]
##' @param \dots additional parameters from \code{\linkS4class{GeneralSimulations}}
##' @return the \code{\linkS4class{PseudoSimulations}} object
##'
##' @export
PseudoSimulations <- function(fit,
                              FinalTDtargetDuringTrialEstimates,
                              FinalTDtargetEndOfTrialEstimates,
                              FinalTDtargetDuringTrialAtDoseGrid,
                              FinalTDtargetEndOfTrialAtDoseGrid,
                              FinalTDEOTCIs,
                              FinalTDEOTRatios,
                              FinalCIs,
                              FinalRatios,
                              stop_report,
                              stopReasons,
                              ...) {
  start <- GeneralSimulations(...)
  .PseudoSimulations(start,
    fit = fit,
    FinalTDtargetDuringTrialEstimates = FinalTDtargetDuringTrialEstimates,
    FinalTDtargetEndOfTrialEstimates = FinalTDtargetEndOfTrialEstimates,
    FinalTDtargetDuringTrialAtDoseGrid = FinalTDtargetDuringTrialAtDoseGrid,
    FinalTDtargetEndOfTrialAtDoseGrid = FinalTDtargetEndOfTrialAtDoseGrid,
    FinalTDEOTCIs = FinalTDEOTCIs,
    FinalTDEOTRatios = FinalTDEOTRatios,
    FinalCIs = FinalCIs,
    FinalRatios = FinalRatios,
    stop_report = stop_report,
    stopReasons = stopReasons
  )
}

## default constructor ----

#' @rdname PseudoSimulations-class
#' @note Typically, end users will not use the `.DefaultPseudoSimulations()` function.
#' @export
.DefaultPseudoSimulations <- function() {
  stop(paste0("Class PseudoSimulations cannot be instantiated directly.  Please use one of its subclasses instead."))
}

## ===============================================================================
## -------------------------------------------------------------------------------
## Class for Pseudo simulation using DLE and efficacy responses (Pseudo models except 'EffFlexi' model)
## -----------------------------------------------------------------------------------

##' Class `PseudoDualSimulations`
##'
##' This is a class which captures the trial simulations design using both the
##' DLE and efficacy responses. The design of model from \code{\linkS4class{ModelTox}}
##' class and the efficacy model from \code{\linkS4class{ModelEff}} class
##' (except \code{\linkS4class{EffFlexi}} class). It contains all slots from
##' \code{\linkS4class{GeneralSimulations}} and \code{\linkS4class{PseudoSimulations}} object.
##' In comparison to the parent class \code{\linkS4class{PseudoSimulations}},
##' it contains additional slots to
##' capture the dose-efficacy curve and the sigma2 estimates.
##'
##' @slot fitEff list of the final values. If DLE and efficacy samples are generated, it contains the
##' final fitted values. If no DLE and efficacy samples are used, it contains the modal estimates of the
##' parameters in the two models and the posterior estimates of the probabilities of the occurrence of a
##' DLE and the expected efficacy responses.
##' @slot FinalGstarEstimates a vector of the final estimates of Gstar at the end of each simulations.
##' @slot FinalGstarAtDoseGrid is a vector of the final estimates of Gstar at dose Grid at the end of each simulations
##' @slot FinalGstarCIs is the list of all 95% credibility interval of the final estimates of Gstar
##' @slot FinalGstarRatios is the vector of the ratios of the CI, the ratio of the upper to the lower 95% credibility interval
##' of the final estimates of Gstar
##' @slot FinalOptimalDose is the vector of the final optimal dose, the minimum of the final TDtargetEndOfTrial estimates and Gstar
##' estimates
##' @slot FinalOptimalDoseAtDoseGrid is the vector of the final optimal dose, the minimum of the final TDtargetEndOfTrial estimates
##' and Gstar estimates at dose Grid
##' @slot sigma2est the vector of the final posterior mean sigma2 estimates
##'
##' @export
.PseudoDualSimulations <-
  setClass(
    Class = "PseudoDualSimulations",
    representation(
      fitEff = "list",
      FinalGstarEstimates = "numeric",
      FinalGstarAtDoseGrid = "numeric",
      FinalGstarCIs = "list",
      FinalGstarRatios = "numeric",
      FinalOptimalDose = "numeric",
      FinalOptimalDoseAtDoseGrid = "numeric",
      sigma2est = "numeric"
    ),
    prototype(
      FinalGstarEstimates = c(0.1, 0.1),
      FinalGstarAtDoseGrid = c(0.1, 0.1),
      FinalGstarCIs = list(
        c(0.1, 0.2),
        c(0.1, 0.2)
      ),
      FinalGstarRatios = c(0.01, 0.01),
      FinalOptimalDose = c(0.01, 0.01),
      FinalOptimalDoseAtDoseGrid = c(0.01, 0.01),
      sigma2est = c(0.001, 0.002)
    ),
    contains = "PseudoSimulations",
    validity = v_pseudo_dual_simulations
  )

validObject(.PseudoDualSimulations())

##' Initialization function for 'DualPseudoSimulations' class
##' @param fitEff please refer to \code{\linkS4class{PseudoDualSimulations}} class object
##' @param  FinalGstarEstimates please refer to \code{\linkS4class{PseudoDualSimulations}} class object
##' @param FinalGstarAtDoseGrid please refer to \code{\linkS4class{PseudoDualSimulations}} class object
##' @param FinalGstarCIs please refer to \code{\linkS4class{PseudoDualSimulations}} class object
##' @param FinalGstarRatios please refer to \code{\linkS4class{PseudoDualSimulations}} class object
##' @param FinalOptimalDose please refer to \code{\linkS4class{PseudoDualSimulations}} class object
##' @param FinalOptimalDoseAtDoseGrid please refer to \code{\linkS4class{PseudoDualSimulations}} class object
##' @param sigma2est please refer to \code{\linkS4class{PseudoDualSimulations}} class object
##' @param \dots additional parameters from \code{\linkS4class{PseudoSimulations}}
##' @return the \code{\linkS4class{PseudoDualSimulations}} object
PseudoDualSimulations <- function(fitEff,
                                  FinalGstarEstimates,
                                  FinalGstarAtDoseGrid,
                                  FinalGstarCIs,
                                  FinalGstarRatios,
                                  FinalOptimalDose,
                                  FinalOptimalDoseAtDoseGrid,
                                  sigma2est,
                                  ...) {
  start <- PseudoSimulations(...)
  .PseudoDualSimulations(start,
    fitEff = fitEff,
    FinalGstarEstimates = FinalGstarEstimates,
    FinalGstarAtDoseGrid = FinalGstarAtDoseGrid,
    FinalGstarCIs = FinalGstarCIs,
    FinalGstarRatios = FinalGstarRatios,
    FinalOptimalDose = FinalOptimalDose,
    FinalOptimalDoseAtDoseGrid = FinalOptimalDoseAtDoseGrid,
    sigma2est = sigma2est
  )
}


## default constructor ----

#' @rdname PseudoDualSimulations-class
#' @note Typically, end users will not use the `.DefaultPseudoDualSimulations()` function.
#' @export
.DefaultPseudoDualSimulations <- function() {
  stop(paste0("Class PseudoDualSimulations cannot be instantiated directly.  Please use one of its subclasses instead."))
}


# PseudoDualFlexiSimulations ----

## class ----

## -------------------------------------------------------------------------------
## Class for Pseudo simulation using DLE and efficacy responses using 'EffFlex' efficacy model
## -----------------------------------------------------------------------------------
##' This is a class which captures the trial simulations design using both the
##' DLE and efficacy responses. The design of model from \code{\linkS4class{ModelTox}}
##' class and the efficacy model from \code{\linkS4class{EffFlexi}} class
##'  It contains all slots from
##' \code{\linkS4class{GeneralSimulations}}, \code{\linkS4class{PseudoSimulations}}
##' and \code{\linkS4class{PseudoDualSimulations}} object.
##' In comparison to the parent class \code{\linkS4class{PseudoDualSimulations}},
##' it contains additional slots to
##' capture the sigma2betaW estimates.
##'
##' @slot sigma2betaWest the vector of the final posterior mean sigma2betaW estimates
##'
##' @export
##' @keywords class
.PseudoDualFlexiSimulations <-
  setClass(
    Class = "PseudoDualFlexiSimulations",
    representation(sigma2betaWest = "numeric"),
    prototype(sigma2betaWest = c(0.001, 0.002)),
    contains = "PseudoDualSimulations",
    validity = v_pseudo_dual_flex_simulations
  )

validObject(.PseudoDualFlexiSimulations())

##' Initialization function for 'PseudoDualFlexiSimulations' class
##' @param sigma2betaWest please refer to \code{\linkS4class{PseudoDualFlexiSimulations}} class object
##' @param \dots additional parameters from \code{\linkS4class{PseudoDualSimulations}}
##' @return the \code{\linkS4class{PseudoDualFlexiSimulations}} object
PseudoDualFlexiSimulations <- function(sigma2betaWest,
                                       ...) {
  start <- PseudoDualSimulations(...)
  .PseudoDualFlexiSimulations(start,
    sigma2betaWest = sigma2betaWest
  )
}

## default constructor ----

#' @rdname PseudoDualFlexiSimulations-class
#' @note Typically, end users will not use the `.DefaultPseudoFlexiSimulations()` function.
#' @export
.DefaultPseudoDualFlexiSimulations <- function() {
  stop(paste0("Class PseudoFlexiSimulations cannot be instantiated directly.  Please use one of its subclasses instead."))
}

## -------------------------------------------------------------------------------------------------------
## ================================================================================================

##' Class for the summary of pseudo-models simulations output
##'
##' Note that objects should not be created by users, therefore no
##' initialization function is provided for this class.
##'
##' @slot targetEndOfTrial the target probability of DLE wanted at the end of a trial
##' @slot targetDoseEndOfTrial the dose level corresponds to the target probability
##' of DLE wanted at the end of a trial, TDEOT
##' @slot targetDoseEndOfTrialAtDoseGrid the dose level at dose grid corresponds to the target probability
##' of DLE wanted at the end of a trial
##' @slot targetDuringTrial the target probability of DLE wanted during a trial
##' @slot targetDoseDuringTrial the dose level corresponds to the target probability of DLE
##' wanted during the trial. TDDT
##' @slot targetDoseDuringTrialAtDoseGrid the dose level at dose grid corresponds to the target probability
##' of DLE wanted during a trial
##' @slot TDEOTSummary the six-number table summary, include the lowest, the 25th precentile (lower quartile),
##' the 50th percentile (median), the mean, the 27th percentile and the highest values of the
##' final dose levels obtained corresponds to the target probability of DLE
##' want at the end of a trial across all simulations
##' @slot TDDTSummary the six-number table summary, include the lowest, the 25th precentile (lower quartile),
##' the 50th percentile (median), the mean, the 27th percentile and the highest values of the
##' final dose levels obtained corresponds to the target probability of DLE
##' want during a trial across all simulations
##' @slot FinalDoseRecSummary the six-number table summary, include the lowest, the 25th precentile (lower quartile),
##' the 50th percentile (median), the mean, the 27th percentile and the highest values of the
##' final optimal doses, which is either the TDEOT when only DLE response are incorporated into
##' the escalation procedure or the minimum of the TDEOT and Gstar when DLE and efficacy responses are
##' incorporated, across all simulations
##' @slot ratioTDEOTSummary the six-number summary table of the final ratios of the upper to the lower 95%
##' credibility intervals of the final TDEOTs across all simulations
##' @slot FinalRatioSummary the six-number summary table of the final ratios of the upper to the lower 95%
##' credibility intervals of the final optimal doses across all simulations
##' #@slot doseRec the dose level that will be recommend for subsequent study
##' @slot nsim number of simulations
##' @slot propDLE proportions of DLE in the trials
##' @slot meanToxRisk mean toxicity risks for the patients
##' @slot doseSelected doses selected as MTD (targetDoseEndOfTrial)
##' @slot toxAtDosesSelected true toxicity at doses selected
##' @slot propAtTargetEndOfTrial Proportion of trials selecting at the doseGrid closest below the MTD, the
##' targetDoseEndOfTrial
##' @slot propAtTargetDuringTrial Proportion of trials selecting at the doseGrid closest below the
##' targetDoseDuringTrial
##' @slot doseMostSelected dose most often selected as MTD
##' @slot obsToxRateAtDoseMostSelected observed toxicity rate at dose most often
##' selected
##' @slot nObs number of patients overall
##' @slot nAboveTargetEndOfTrial number of patients treated above targetDoseEndOfTrial
##' @slot nAboveTargetDuringTrial number of patients treated above targetDoseDuringTrial
##' @slot doseGrid the dose grid that has been used
##' @slot fitAtDoseMostSelected fitted toxicity rate at dose most often selected
##' @slot meanFit list with the average, lower (2.5%) and upper (97.5%)
##' quantiles of the mean fitted toxicity at each dose level
##' @slot stop_report matrix of stopping rule outcomes
##'
##' @export
##' @keywords classes
.PseudoSimulationsSummary <-
  setClass(
    Class = "PseudoSimulationsSummary",
    representation(
      targetEndOfTrial = "numeric",
      targetDoseEndOfTrial = "numeric",
      targetDoseEndOfTrialAtDoseGrid = "numeric",
      targetDuringTrial = "numeric",
      targetDoseDuringTrial = "numeric",
      targetDoseDuringTrialAtDoseGrid = "numeric",
      TDEOTSummary = "table",
      TDDTSummary = "table",
      FinalDoseRecSummary = "table",
      ratioTDEOTSummary = "table",
      FinalRatioSummary = "table",
      # doseRec="numeric",
      nsim = "integer",
      propDLE = "numeric",
      meanToxRisk = "numeric",
      doseSelected = "numeric",
      toxAtDosesSelected = "numeric",
      propAtTargetEndOfTrial = "numeric",
      propAtTargetDuringTrial = "numeric",
      doseMostSelected = "numeric",
      obsToxRateAtDoseMostSelected = "numeric",
      nObs = "integer",
      nAboveTargetEndOfTrial = "integer",
      nAboveTargetDuringTrial = "integer",
      doseGrid = "numeric",
      fitAtDoseMostSelected = "numeric",
      meanFit = "list",
      stop_report = "matrix"
    )
  )

## default constructor ----

#' @rdname GeneralSimulationsSummary-class
#' @note Typically, end users will not use the `.DefaultPseudoSimulationsSummary()` function.
#' @export
.DefaultPseudoSimulationsSummary <- function() {
  stop(paste0("Class PseudoSimulationsSummary cannot be instantiated directly.  Please use one of its subclasses instead."))
}

## ---------------------------------------------------------------------------------------------
##' Class for the summary of the dual responses simulations using pseudo models
##'
##' It contains all slots from \code{\linkS4class{PseudoSimulationsSummary}} object. In addition to
##' the slots in the parent class \code{\linkS4class{PseudoSimulationsSummary}}, it contains four
##' more slots for the efficacy model fit information.
##'
##' Note that objects should not be created by users, therefore no initialization function
##' is provided for this class.
##'
##' @slot targetGstar the target dose level such that its gain value is at maximum
##' @slot targetGstarAtDoseGrid the dose level at dose Grid closest and below Gstar
##' @slot GstarSummary the six-number table summary (lowest, 25th, 50th (median), 75th percentile, mean
##' and highest value) of the final Gstar values obtained across all simulations
##' @slot ratioGstarSummary the six-number summary table of the ratios of the upper to the lower 95%
##' credibility intervals of the final Gstar across all simulations
##' @slot EffFitAtDoseMostSelected fitted expected mean efficacy value at dose most often
##' selected
##' @slot meanEffFit list with mean, lower (2.5%) and upper (97.5%) quantiles of the fitted expected
##' efficacy value at each dose level.
##'
##' @export
##' @keywords class
.PseudoDualSimulationsSummary <-
  setClass(
    Class = "PseudoDualSimulationsSummary",
    contains = "PseudoSimulationsSummary",
    representation =
      representation(
        targetGstar = "numeric",
        targetGstarAtDoseGrid = "numeric",
        GstarSummary = "table",
        ratioGstarSummary = "table",
        EffFitAtDoseMostSelected = "numeric",
        meanEffFit = "list"
      )
  )

## default constructor ----

#' @rdname PseudoDualSimulationsSummary-class
#' @note Typically, end users will not use the `.DefaultPseudoDualSimulationsSummary()` function.
#' @export
.DefaultPseudoDualSimulationsSummary <- function() {
  stop(paste0("Class PseudoDualSimulationsSummary cannot be instantiated directly.  Please use one of its subclasses instead."))
}

## ---------------------------------------------------------------------------------------------

##' Class for the simulations output from DA based designs
##'
##' This class captures the trial simulations from DA based
##' designs. In comparison to the parent class \code{\linkS4class{Simulations}},
##' it contains additional slots to capture the time to DLT fits, additional
##' parameters and the trial duration.
##'
##' @slot trialduration the vector of trial duration values for all simulations.
##'
##' @export
##' @keywords classes
.DASimulations <-
  setClass(
    Class = "DASimulations",
    representation(trialduration = "numeric"),
    prototype(trialduration = rep(0, 2)),
    contains = "Simulations",
    validity = v_da_simulations
  )
validObject(.DASimulations())


##' Initialization function for `DASimulations`
##'
##' @param trialduration see \code{\linkS4class{DASimulations}}
##' @param \dots additional parameters from \code{\link{Simulations}}
##' @return the \code{\linkS4class{DASimulations}} object
##'
##' @export
##' @keywords methods
DASimulations <- function(trialduration,
                          ...) {
  start <- Simulations(...)
  .DASimulations(start,
    trialduration = trialduration
  )
}


## default constructor ----

#' @rdname DASimulations-class
#' @note Typically, end users will not use the `.DASimulations()` function.
#' @export
.DefaultDASimulations <- function() {
  design <- .DefaultDADesign()
  myTruth <- probFunction(design@model, alpha0 = 2, alpha1 = 3)
  exp_cond.cdf <- function(x, onset = 15) {
    a <- stats::pexp(28, 1 / onset, lower.tail = FALSE)
    1 - (stats::pexp(x, 1 / onset, lower.tail = FALSE) - a) / (1 - a)
  }

  simulate(
    design,
    args = NULL,
    truthTox = myTruth,
    truthSurv = exp_cond.cdf,
    trueTmax = 80,
    nsim = 2,
    seed = 819,
    mcmcOptions = .DefaultMcmcOptions(),
    firstSeparate = TRUE,
    deescalate = FALSE,
    parallel = FALSE
  )
}
# nolint end

# tidy

## tidy-Simulations ----

#' @rdname tidy
#' @aliases tidy-Simulations
#' @example examples/Simulations-method-tidy.R
#' @export
setMethod(
  f = "tidy",
  signature = signature(x = "Simulations"),
  definition = function(x, ...) {
    slot_names <- slotNames(x)
    rv <- list()
    for (nm in slot_names) {
      if (!is.function(slot(x, nm))) {
        if (nm %in% c("stop_reasons", "additional_stats")) {
        } else {
          rv[[nm]] <- h_tidy_slot(x, nm)
        }
      }
    }
    # Column bind of all list elements have the same number of rows
    if (length(rv) > 1 & length(unique(sapply(rv, nrow))) == 1) {
      rv <- rv %>% dplyr::bind_cols()
    }
    rv %>% h_tidy_class(x)
  }
)

#' @include helpers_data.R

# plot ----

## Data ----

#' Plot Method for the [`Data`] Class
#'
#' @description `r lifecycle::badge("stable")`
#'
#' A method that creates a plot for [`Data`] object.
#'
#' @return The [`ggplot2`] object.
#'
#' @aliases plot-Data
#' @rdname plot-Data
#' @export
#' @example examples/Data-method-plot.R
#'
setMethod(
  f = "plot",
  signature = signature(x = "Data", y = "missing"),
  definition = function(x, y, blind = FALSE, legend = TRUE, ...) {
    assert_flag(blind)
    assert_flag(legend)
    h_plot_data_dataordinal(x, blind, legend, ...)
  }
)

#' Plot Method for the [`DataOrdinal`] Class
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' A method that creates a plot for [`DataOrdinal`] object.
#'
#' @param x (`DataOrdinal`)\cr object we want to plot.
#' @param y (`missing`)\cr missing object, for compatibility with the generic
#'   function.
#' @param blind (`flag`)\cr indicates whether to blind the data.
#'   If `TRUE`, then placebo subjects are reported at the same level
#'   as the active dose level in the corresponding cohort,
#'   and DLTs are always assigned to the first subjects in a cohort.
#' @param legend (`flag`)\cr whether the legend should be added.
#' @param tox_labels (`named list of character`)\cr the labels of the toxicity
#' categories.
#' @param tox_shapes (`names list of integers`)\cr the symbols used to identify
#' the toxicity categories.
#' @param ... not used.
#'
#' @note With more than 9 toxicity categories, toxicity symbols must be
#' specified manually.\cr With more than 5 toxicity categories, toxicity labels
#' must be specified manually.
#'
#' @return The [`ggplot2`] object.
#'
#' @rdname plot-Data
#' @export
#' @example examples/DataOrdinal-method-plot.R
setMethod(
  f = "plot",
  signature = signature(x = "DataOrdinal", y = "missing"),
  definition = function(x,
                        y,
                        blind = FALSE,
                        legend = TRUE,
                        tox_labels = NULL,
                        tox_shapes = NULL,
                        ...) {
    if (is.null(tox_shapes)) {
      assert_true(length(x@yCategories) <= 9)
      tox_shapes <- c(17L, 16L, 15L, 18L, 0L:2L, 5L, 6L)[seq_along(x@yCategories)]
      names(tox_shapes) <- names(x@yCategories)
    }
    if (is.null(tox_labels)) {
      assert_true(length(x@yCategories) <= 5)
      tox_labels <- switch(length(x@yCategories),
        c("black"),
        c("black", "red"),
        c("black", "orange", "red"),
        c("black", "green", "orange", "red"),
        c("black", "green", "yellow", "orange", "red")
      )
      names(tox_labels) <- names(x@yCategories)
    }
    h_plot_data_dataordinal(
      x,
      blind,
      legend,
      tox_labels = tox_labels,
      tox_shapes = tox_shapes,
      ...
    )
  }
)

## DataDual ----

#' Plot Method for the [`DataDual`] Class
#'
#' @description `r lifecycle::badge("stable")`
#'
#' A method that creates a plot for [`DataDual`] object.
#'
#' @param x (`DataDual`)\cr object we want to plot.
#' @param y (`missing`)\cr missing object, for compatibility with the generic
#'   function.
#' @param blind (`flag`)\cr indicates whether to blind the data.
#'   If `TRUE`, then placebo subjects are reported at the same level
#'   as the active dose level in the corresponding cohort,
#'   and DLTs are always assigned to the first subjects in a cohort.
#' @param ... passed to the first inherited method `plot` after this current
#'   method.
#'
#' @return The [`ggplot2`] object.
#'
#' @aliases plot-DataDual
#' @export
#' @example examples/Data-method-plot-DataDual.R
#'
setMethod(
  f = "plot",
  signature = signature(x = "DataDual", y = "missing"),
  definition = function(x, y, blind = FALSE, ...) {
    assert_flag(blind)

    # Call the superclass method, to get the first plot.
    plot1 <- callNextMethod(x, blind = blind, legend = FALSE, ...)

    # Create the second, biomarker plot.
    df <- h_plot_data_df(x, blind, biomarker = x@w)

    plot2 <- ggplot(df, aes(x = dose, y = biomarker)) +
      geom_point(aes(shape = toxicity, colour = toxicity), size = 3) +
      scale_colour_manual(
        name = "Toxicity", values = c(Yes = "red", No = "black")
      ) +
      scale_shape_manual(name = "Toxicity", values = c(Yes = 17, No = 16)) +
      xlab("Dose Level") +
      ylab("Biomarker")

    if (!blind) {
      plot2 <- plot2 +
        geom_text(
          aes(
            y = biomarker + 0.02 * diff(range(biomarker)),
            label = patient, size = 2
          ),
          data = df,
          hjust = 0,
          vjust = 0.5,
          angle = 90,
          colour = "black",
          show.legend = FALSE
        )
    }

    # Arrange both plots side by side.
    gridExtra::arrangeGrob(plot1, plot2, ncol = 2)
  }
)

## DataDA ----

#' Plot Method for the [`DataDA`] Class
#'
#' @description `r lifecycle::badge("stable")`
#'
#' A method that creates a plot for [`DataDA`] object.
#'
#' @param x (`DataDA`)\cr object we want to plot.
#' @param y (`missing`)\cr missing object, for compatibility with the generic
#'   function.
#' @param blind (`flag`)\cr indicates whether to blind the data.
#'   If `TRUE`, then placebo subjects are reported at the same level
#'   as the active dose level in the corresponding cohort,
#'   and DLTs are always assigned to the first subjects in a cohort.
#' @param ... passed to the first inherited method `plot` after this current
#'   method.
#'
#' @return The [`ggplot2`] object.
#'
#' @aliases plot-DataDA
#' @export
#' @example examples/Data-method-plot-DataDA.R
#'
setMethod(
  f = "plot",
  signature = signature(x = "DataDA", y = "missing"),
  definition = function(x, y, blind = FALSE, ...) {
    assert_flag(blind)

    # Call the superclass method, to get the first plot.
    plot1 <- callNextMethod(x, blind = blind, legend = FALSE, ...)

    # Prepare data set for the second, time plot.
    df <- h_plot_data_df(x, blind, u = x@u, t0 = x@t0)
    df$censored <- ifelse(df$u < x@Tmax & df$toxicity == 0, 1, 0)
    df$tend <- df$t0 + df$u # `tend` stands for `time end`
    df$t0_case <- "Start"
    df$tend_case <- ifelse(
      df$toxicity == "Yes",
      "Yes",
      ifelse(df$censored, "Censored", "No")
    )

    # Build plot object.
    plot2 <- ggplot(df, aes(x = t0, y = patient)) +
      geom_segment(aes(xend = tend, yend = patient)) +
      geom_point(aes(shape = t0_case, colour = t0_case), size = 3) +
      geom_point(
        aes(x = tend, shape = tend_case, colour = tend_case),
        size = 3
      ) +
      scale_colour_manual(
        name = "Toxicity",
        values = c(
          Yes = "red", No = "black", Start = "black", Censored = "black"
        )
      ) +
      scale_shape_manual(
        name = "Toxicity",
        values = c(Yes = 17, No = 16, Start = 1, Censored = 4)
      ) +
      scale_y_continuous(breaks = df$patient, minor_breaks = NULL) +
      xlab("Time") +
      ylab("Patient")

    plot2 <- plot2 +
      h_plot_data_cohort_lines(df$cohort, placebo = x@placebo, vertical = FALSE)

    if (!blind) {
      plot2 <- plot2 +
        geom_text(
          aes(label = ID, size = 2),
          size = 3,
          hjust = 1.5,
          vjust = 0,
          angle = 0,
          colour = "black",
          show.legend = FALSE
        )
    }

    # Arrange both plots side by side.
    gridExtra::arrangeGrob(plot1, plot2, ncol = 1)
  }
)

# update ----

## Data ----

#' Updating `Data` Objects
#'
#' @description `r lifecycle::badge("stable")`
#'
#' A method that updates existing [`Data`] object with new data.
#'
#' @param object (`Data`)\cr object you want to update.
#' @param x (`number`)\cr the dose level (one level only!).
#' @param y (`integer`)\cr the DLT vector (0/1 vector) for all patients in this
#'   cohort. You can also supply `numeric` vectors, but these will then be
#'   converted to `integer` internally.
#' @param ID (`integer`)\cr the patient IDs.
#'   You can also supply `numeric` vectors, but these will then be converted to
#'   `integer` internally.
#' @param new_cohort (`flag`)\cr if `TRUE` (default) the new data are assigned
#'   to a new cohort.
#' @param check (`flag`)\cr whether the validation of the updated object should
#'   be conducted. See details below.
#' @param ... not used.
#'
#' @return The new, updated [`Data`] object.
#'
#' @details The current implementation of this `update` method allows for
#'   updating the `Data` class object by adding a single dose level `x` only.
#'   However, there might be some use cases where the new cohort to be added
#'   contains a placebo and active dose. Hence, such update would need to be
#'   performed iteratively by calling the `update` method twice. For example,
#'   in the first call a user can add a placebo, and then in the second call,
#'   an active dose. Since having a cohort with placebo only is not allowed,
#'   the `update` method would normally throw the error when attempting to add
#'   a placebo in the first call. To allow for such updates, the `check`
#'   parameter should be then set to `FALSE` for that first call.
#'
#' @aliases update-Data
#' @export
#' @example examples/Data-method-update.R
#'
setMethod(
  f = "update",
  signature = signature(object = "Data"),
  definition = function(object,
                        x,
                        y,
                        ID = length(object@ID) + seq_along(y),
                        new_cohort = TRUE,
                        check = TRUE,
                        ...) {
    assert_numeric(x, min.len = 0, max.len = 1)
    assert_integerish(y, lower = 0, upper = 1, any.missing = FALSE)
    assert_integerish(ID, len = length(y), any.missing = FALSE)
    assert_disjunct(object@ID, ID)
    assert_flag(new_cohort)
    assert_flag(check)

    # How many additional patients, ie. the length of the update.
    n <- length(y)

    # Which grid level is the dose?
    gridLevel <- match_within_tolerance(x, object@doseGrid)
    object@xLevel <- c(object@xLevel, rep(gridLevel, n))

    # Add dose.
    object@x <- c(object@x, rep(as.numeric(x), n))

    # Add DLT data.
    object@y <- c(object@y, as.integer(y))

    # Add ID.
    object@ID <- c(object@ID, as.integer(ID))

    # Add cohort number.
    new_cohort_id <- if (object@nObs == 0) {
      1L
    } else {
      tail(object@cohort, 1L) + ifelse(new_cohort, 1L, 0L)
    }
    object@cohort <- c(object@cohort, rep(new_cohort_id, n))

    # Increment sample size.
    object@nObs <- object@nObs + n

    if (check) {
      validObject(object)
    }

    object
  }
)

## DataOrdinal ----

#' Updating `DataOrdinal` Objects
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' A method that updates existing [`DataOrdinal`] object with new data.
#'
#' @param object (`DataOrdinal`)\cr object you want to update.
#' @param x (`number`)\cr the dose level (one level only!).
#' @param y (`integer`)\cr the vector of toxicity grades (0, 1, 2, ...) for all
#' patients in this cohort. You can also supply `numeric` vectors, but these
#' will then be converted to `integer` internally.
#' @param ID (`integer`)\cr the patient IDs.
#'   You can also supply `numeric` vectors, but these will then be converted to
#'   `integer` internally.
#' @param new_cohort (`flag`)\cr if `TRUE` (default) the new data are assigned
#'   to a new cohort.
#' @param check (`flag`)\cr whether the validation of the updated object should
#'   be conducted. See Details below.
#' @param ... not used.
#'
#' @return The new, updated [`DataOrdinal`] object.
#'
#' @details The current implementation of this `update` method allows for
#'   updating the `DataOrdinal` class object by adding a single dose level `x` only.
#'   However, there might be some use cases where the new cohort to be added
#'   contains a placebo and active dose. Hence, such update would need to be
#'   performed iteratively by calling the `update` method twice. For example,
#'   in the first call a user can add a placebo, and then in the second call,
#'   an active dose. Since having a cohort with placebo only is not allowed,
#'   the `update` method would normally throw the error when attempting to add
#'   a placebo in the first call. To allow for such updates, the `check`
#'   parameter should be then set to `FALSE` for that first call.
#'
#' @aliases update-DataOrdinal
#' @export
#' @example examples/DataOrdinal-method-update.R
#'
setMethod(
  f = "update",
  signature = signature(object = "DataOrdinal"),
  definition = function(object,
                        x,
                        y,
                        ID = length(object@ID) + seq_along(y),
                        new_cohort = TRUE,
                        check = TRUE,
                        ...) {
    assert_numeric(x, min.len = 0, max.len = 1)
    assert_integerish(y, lower = 0, upper = length(object@yCategories) - 1, any.missing = FALSE)
    assert_integerish(ID, unique = TRUE, any.missing = FALSE, len = length(y))
    assert_disjunct(object@ID, ID)
    assert_flag(new_cohort)
    assert_flag(check)

    # How many additional patients, ie. the length of the update.
    n <- length(y)

    # Which grid level is the dose?
    gridLevel <- match_within_tolerance(x, object@doseGrid)
    object@xLevel <- c(object@xLevel, rep(gridLevel, n))

    # Add dose.
    object@x <- c(object@x, rep(as.numeric(x), n))

    # Add DLT data.
    object@y <- c(object@y, as.integer(y))

    # Add ID.
    object@ID <- c(object@ID, as.integer(ID))

    # Add cohort number.
    new_cohort_id <- if (object@nObs == 0) {
      1L
    } else {
      tail(object@cohort, 1L) + ifelse(new_cohort, 1L, 0L)
    }
    object@cohort <- c(object@cohort, rep(new_cohort_id, n))

    # Increment sample size.
    object@nObs <- object@nObs + n

    if (check) {
      validObject(object)
    }

    object
  }
)

## DataParts ----

#' Updating `DataParts` Objects
#'
#' @description `r lifecycle::badge("stable")`
#'
#' A method that updates existing [`DataParts`] object with new data.
#'
#' @param object (`DataParts`)\cr object you want to update.
#' @inheritParams update,Data-method
#' @param ... further arguments passed to `Data` update method [`update-Data`].
#' @param check (`flag`)\cr whether the validation of the updated object
#'   should be conducted. See help for [`update-Data`] for more details
#'   on the use case of this parameter.
#'
#' @return The new, updated [`DataParts`] object.
#'
#' @aliases update-DataParts
#' @export
#' @example examples/Data-method-update-DataParts.R
#'
setMethod(
  f = "update",
  signature = signature(object = "DataParts"),
  definition = function(object, x, y, ..., check = TRUE) {
    assert_numeric(y)
    assert_flag(check)

    # Update slots corresponding to `Data` class.
    object <- callNextMethod(object = object, x = x, y = y, ..., check = FALSE)

    # Update the part information.

    object@part <- c(object@part, rep(object@nextPart, length(y)))

    # Decide which part the next cohort will belong to:
    # only if the `nextPart` was 1, it can potentially be required
    # to change it to 2 (once it is 2, it stays).
    if (object@nextPart == 1L) {
      # If there was a DLT in one of the cohorts,
      # or if the current dose was the highest from part 1.
      if (any(object@y == 1L) || x == max(object@part1Ladder)) {
        # Then this closes part 1 and the next cohort will be from part 2.
        object@nextPart <- 2L
      }
    }

    if (check) {
      validObject(object)
    }

    object
  }
)

## DataDual ----

#' Updating `DataDual` Objects
#'
#' @description `r lifecycle::badge("stable")`
#'
#' A method that updates existing [`DataDual`] object with new data.
#'
#' @param object (`DataDual`)\cr object you want to update.
#' @param w (`numeric`)\cr the continuous vector of biomarker values
#'   for all the patients in this update.
#' @param ... further arguments passed to `Data` update method [`update-Data`].
#' @param check (`flag`)\cr whether the validation of the updated object
#'   should be conducted. See help for [`update-Data`] for more details
#'   on the use case of this parameter.
#'
#' @return The new, updated [`DataDual`] object.
#'
#' @aliases update-DataDual
#' @export
#' @example examples/Data-method-update-DataDual.R
#'
setMethod(
  f = "update",
  signature = signature(object = "DataDual"),
  definition = function(object, w, ..., check = TRUE) {
    assert_numeric(w)
    assert_flag(check)

    # Update slots corresponding to `Data` class.
    object <- callNextMethod(object = object, ..., check = FALSE)

    # Update the biomarker information.
    object@w <- c(object@w, w)

    if (check) {
      validObject(object)
    }

    object
  }
)

## DataDA ----

#' Updating `DataDA` Objects
#'
#' @description `r lifecycle::badge("stable")`
#'
#' A method that updates existing [`DataDA`] object with new data.
#'
#' @note This function is capable of not only adding new patients but also
#'   updates existing ones with respect to `y`, `t0`, `u` slots.
#'
#' @param object (`DataDA`)\cr object you want to update.
#' @param u (`numeric`)\cr the new DLT free survival times for all patients,
#'   i.e. for existing patients in the `object` as well as for new patients.
#' @param t0 (`numeric`)\cr the time that each patient starts DLT observation
#'   window. This parameter covers all patients, i.e. existing patients in the
#'   `object` as well as for new patients.
#' @param trialtime (`number`)\cr current time in the trial, i.e. a followup
#'   time.
#' @param y (`numeric`)\cr the new DLTs for all patients, i.e. for existing
#'   patients in the `object` as well as for new patients.
#' @param ... further arguments passed to `Data` update method [`update-Data`].
#'   These are used when there are new patients to be added to the cohort.
#' @param check (`flag`)\cr whether the validation of the updated object
#'   should be conducted. See help for [`update-Data`] for more details
#'   on the use case of this parameter.
#'
#' @return The new, updated [`DataDA`] object.
#'
#' @aliases update-DataDA
#' @export
#' @example examples/Data-method-update-DataDA.R
#'
setMethod(
  f = "update",
  signature = signature(object = "DataDA"),
  definition = function(object,
                        u,
                        t0,
                        trialtime,
                        y,
                        ...,
                        check = TRUE) {
    assert_flag(check)
    assert_numeric(y, lower = 0, upper = 1)
    assert_true(length(y) == 0 || length(y) >= object@nObs)
    assert_numeric(u, lower = 0, len = length(y))
    assert_numeric(t0, lower = 0, len = length(y))
    assert_integerish(y * (trialtime >= t0 + u))
    if (length(y) > 0) {
      assert_number(trialtime, lower = max(c(object@t0, t0)))
    }

    # How many additional patients.
    n <- max(length(y) - object@nObs, 0L)

    # Update slots corresponding to `Data` class.
    object <- callNextMethod(
      object = object,
      y = y[object@nObs + seq_len(n)], # Empty vector when n = 0.
      ...,
      check = FALSE
    )

    # DLT will be observed once the followup time >= the time to DLT
    # and y = 1 at the same time.
    object@y <- as.integer(y * (trialtime >= t0 + u))

    # Update DLT free survival time.
    object@u <- apply(rbind(u, trialtime - t0), 2, min)

    # Update t0.
    object@t0 <- t0

    if (check) {
      validObject(object)
    }

    object
  }
)

# getEff ----

## generic ----

#' Extracting Efficacy Responses for Subjects Categorized by the DLT
#'
#' @description `r lifecycle::badge("stable")`
#'
#' A method that extracts efficacy responses for subjects and categorizes it
#' with respect to DLT, i.e. DLT or no DLT. The efficacy responses
#' are reported together with their corresponding dose levels.
#'
#' @param object (`DataDual`)\cr object from which the responses and dose levels
#'   are extracted.
#' @param ... further arguments passed to class-specific methods.
#' @return `list` with efficacy responses categorized by the DLT value.
#' @export
#'
setGeneric(
  name = "getEff",
  def = function(object, ...) {
    standardGeneric("getEff")
  },
  valueClass = "list"
)

## DataDual ----

#' @rdname getEff
#'
#' @param no_dlt (`flag`)\cr should only no DLT responses be returned? Otherwise,
#'   all responses are returned.
#'
#' @aliases getEff-DataDual
#' @example examples/Data-method-getEff.R
#'
setMethod(
  f = "getEff",
  signature = signature(object = "DataDual"),
  definition = function(object, no_dlt = FALSE) {
    assert_flag(no_dlt)

    is_dlt <- object@y == 1L
    is_no_dlt <- !is_dlt

    eff <- if (any(is_no_dlt)) {
      list(x_no_dlt = object@x[is_no_dlt], w_no_dlt = object@w[is_no_dlt])
    } else {
      list(x_no_dlt = NULL, w_no_dlt = NULL)
    }

    if (!no_dlt) {
      eff_dlt <- if (any(is_dlt)) {
        list(x_dlt = object@x[is_dlt], w_dlt = object@w[is_dlt])
      } else {
        list(x_dlt = NULL, w_dlt = NULL)
      }
      eff <- c(eff, eff_dlt)
    }
    eff
  }
)

# ngrid ----

## generic ----

#' Number of Doses in Grid
#'
#' @description `r lifecycle::badge("stable")`
#'
#' A function that gets the number of doses in grid. User can choose whether
#' the placebo dose (if any) should be counted or not.
#'
#' @param object (`Data`)\cr object with dose grid.
#' @param ignore_placebo (`flag`)\cr should placebo dose (if any) not be counted?
#' @param ... further arguments passed to class-specific methods.
#' @return `integer` the number of doses in grid.
#' @export
#'
setGeneric(
  name = "ngrid",
  def = function(object, ignore_placebo = TRUE, ...) {
    assert_flag(ignore_placebo)
    standardGeneric("ngrid")
  },
  valueClass = "integer"
)

## Data ----

#' @rdname ngrid
#'
#' @aliases ngrid-Data
#' @example examples/Data-method-ngrid.R
#'
setMethod(
  f = "ngrid",
  signature = signature(object = "Data"),
  definition = function(object, ignore_placebo, ...) {
    if (ignore_placebo && object@placebo) {
      max(object@nGrid - 1L, 0L)
    } else {
      object@nGrid
    }
  }
)

# dose_grid_range ----

## generic ----

#' Getting the Dose Grid Range
#'
#' @description `r lifecycle::badge("stable")`
#'
#' A function that returns a vector of length two with the minimum and maximum
#' dose in a grid. It returns `c(-Inf, Inf)` if the range cannot be determined,
#' which happens when the dose grid is empty. User can choose whether the
#' placebo dose (if any) should be counted or not.
#'
#' @param object (`Data`)\cr object with dose grid.
#' @param ... further arguments passed to class-specific methods.
#' @return A `numeric` vector containing the minimum and maximum of all the
#'   doses in a grid or `c(-Inf, Inf)`.
#'
#' @export
#'
setGeneric(
  name = "dose_grid_range",
  def = function(object, ...) {
    standardGeneric("dose_grid_range")
  },
  valueClass = "numeric"
)

## Data ----

#' @rdname dose_grid_range
#'
#' @param ignore_placebo (`flag`)\cr should placebo dose (if any) not be counted?
#'
#' @aliases dose_grid_range-Data
#' @example examples/Data-method-dose_grid_range.R
#'
setMethod(
  f = "dose_grid_range",
  signature = signature(object = "Data"),
  definition = function(object, ignore_placebo = TRUE) {
    h_obtain_dose_grid_range(object, ignore_placebo)
  }
)


## DataOrdinal ----

#' @include Data-methods.R
#' @rdname dose_grid_range
#' @description `r lifecycle::badge("experimental")`
#'
#' @param ignore_placebo (`flag`)\cr should placebo dose (if any) not be counted?
#'
#' @aliases dose_grid_range-Data
#' @example examples/DataOrdinal-method-dose_grid_range.R
#'
setMethod(
  f = "dose_grid_range",
  signature = signature(object = "DataOrdinal"),
  definition = function(object, ignore_placebo = TRUE) {
    h_obtain_dose_grid_range(object, ignore_placebo)
  }
)

#' @importFrom knitr knit_print
NULL

# Integration with knitr ----
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' We provide additional utility functions to allow human-friendly rendition of
#' crmPack objects in Markdown and Quarto files
#'
#' @return a character string that represents the object in markdown.
#' @name knit_print
NULL

# CohortSize ----

#' Render a CohortSizeConst Object
#'
#' @description `r lifecycle::badge("experimental")`
#' @param x (`CohortSize`)\cr The object to knit_print.
#' @param asis (`flag`)\cr Should the return value be wrapped in a call to `knitr::asis_output`?
#' @param label (`character`)\cr The word used to label the participants.  See Usage Notes below.
#' @param ... Not used at present
#'
#' @section Usage Notes:
#' `label` describes the trial's participants.
#'
#' It should be a character vector of length 1 or 2.  If of length 2, the first
#' element describes a `cohort_size` of 1 and the second describes all other
#' `cohort_size`s.  If of length 1, the character `s` is appended to the value
#' when `cohort_size` is not 1.
#' @return The markdown representation of the object, as a character string
#' @seealso [`knit_print`] for more details.
#'
#' @export
#' @rdname knit_print
knit_print.CohortSizeConst <- function(x, ..., asis = TRUE, label = c("participant", "participants")) {
  assert_character(label, min.len = 1, max.len = 2, any.missing = FALSE)
  assert_flag(asis)

  if (length(label) == 1) {
    label[2] <- paste0(label[1], "s")
  }
  rv <- paste0("A constant size of ", x@size, " ", label[ifelse(x@size == 1, 1, 2)], ".")
  if (asis) {
    rv <- knitr::asis_output(rv)
  }
  rv
}

#' Render a CohortSizeRange Object
#'
#' @description `r lifecycle::badge("experimental")`
#' @param ... passed to `knitr::kable`
#' @inherit knit_print.CohortSizeConst return
#' @section Usage Notes:
#' The default value of `col.names` is `c("Lower", "Upper", "Cohort size")` and
#' that of `caption` is `"Defined by the dose to be used in the next cohort"`.
#' These values can be overridden by passing `col.names` and `caption` in the
#' function call.
#' @export
#' @rdname knit_print
knit_print.CohortSizeRange <- function(x, ..., asis = TRUE) {
  assert_flag(asis)

  param <- list(...)
  if (!("col.names" %in% names(param))) {
    param[["col.names"]] <- c("Lower", "Upper", "Cohort size")
  }
  if (!("caption" %in% names(param))) {
    param[["caption"]] <- "Defined by the dose to be used in the next cohort"
  }
  x <- tidy(x)
  param[["x"]] <- x
  rv <- kableExtra::add_header_above(
    do.call(knitr::kable, param),
    c("Dose" = 2, " " = 1)
  )
  if (asis) {
    rv <- knitr::asis_output(rv)
  }
  rv
}

#' Render a CohortSizeDLT Object
#'
#' @description `r lifecycle::badge("experimental")`
#' @inherit knit_print.CohortSizeConst return
#' @param ... Passed to `knitr::kable`.
#'
#' @section Usage Notes:
#' The by default, the columns are labelled `Lower`, `Upper` and `Cohort size`.  The table's caption is
#' `Defined by the number of DLTs so far observed`.  These values can be overridden by passing
#' `col.names` and `caption` in the function call.
#'
#' @export
#' @rdname knit_print
knit_print.CohortSizeDLT <- function(x, ..., asis = TRUE) {
  assert_flag(asis)

  param <- list(...)
  if (!("col.names" %in% names(param))) {
    param[["col.names"]] <- c("Lower", "Upper", "Cohort size")
  }
  if (!("caption" %in% names(param))) {
    param[["caption"]] <- "Defined by the number of DLTs so far observed"
  }
  param[["x"]] <- tidy(x)
  rv <- kableExtra::add_header_above(
    do.call(knitr::kable, param),
    c("No of DLTs" = 2, " " = 1)
  )
  if (asis) {
    rv <- knitr::asis_output(rv)
  }
  rv
}

#' Render a CohortSizeParts Object
#'
#' @description `r lifecycle::badge("experimental")`
#' @inherit knit_print.CohortSizeConst return
#' @inheritSection knit_print.CohortSizeConst Usage Notes
#'
#' @export
#' @rdname knit_print
knit_print.CohortSizeParts <- function(x, ..., asis = TRUE, label = c("participant", "participants")) {
  assert_character(label, min.len = 1, max.len = 2, any.missing = FALSE)
  assert_flag(asis)

  if (length(label) == 1) {
    label[2] <- paste0(label[1], "s")
  }
  rv <- paste0(
    "A size of ",
    x@cohort_sizes[1],
    " ",
    label[ifelse(x@cohort_sizes[1] == 1, 1, 2)],
    " in the first part and ",
    x@cohort_sizes[2],
    " ",
    label[ifelse(x@cohort_sizes[2] == 1, 1, 2)],
    " in the second."
  )
  if (asis) {
    rv <- knitr::asis_output(rv)
  }
  rv
}

#' Render a CohortSizeMax Object
#'
#' @description `r lifecycle::badge("experimental")`
#' @inherit knit_print.CohortSizeConst return
#' @param ... passed through to the `knit_print` methods of the constituent
#' rules
#'
#' @export
#' @rdname knit_print
knit_print.CohortSizeMax <- function(x, ..., asis = TRUE) {
  assert_flag(asis)
  rv <- paste0(
    "The maximum of the cohort sizes defined in the following rules:",
    paste0(
      lapply(
        x@cohort_sizes,
        function(x, ...) {
          knit_print(x, asis = asis, ...)
        }
      ),
      collapse = "\n"
    ),
    paste = "\n"
  )

  if (asis) {
    rv <- knitr::asis_output(rv)
  }
  rv
}

#' Render a CohortSizeMin Object
#'
#' @description `r lifecycle::badge("experimental")`
#' @inherit knit_print.CohortSizeConst return
#' @param ... passed through to the `knit_print` methods of the constituent
#' rules
#'
#' @export
#' @rdname knit_print
knit_print.CohortSizeMin <- function(x, ..., asis = TRUE) {
  assert_flag(asis)
  rv <- paste0(
    "The minimum of the cohort sizes defined in the following rules:",
    paste0(
      lapply(
        x@cohort_sizes,
        function(x, ...) {
          knit_print(x, asis = asis, ...)
        }
      ),
      collapse = "\n"
    ),
    paste = "\n"
  )
  if (asis) {
    rv <- knitr::asis_output(rv)
  }
  rv
}

#' Render a CohortSizeOrdinal Object
#'
#' @description `r lifecycle::badge("experimental")`
#' @inherit knit_print.CohortSizeConst return
#' @param ... passed through to the `knit_print` method of the standard rule
#'
#' @export
#' @rdname knit_print
knit_print.CohortSizeOrdinal <- function(x, ..., asis = TRUE) {
  rv <- paste0(
    "Based on a toxicity grade of ",
    x@grade,
    ": ",
    paste0(knit_print(x@rule, asis = asis, ...), collapse = "\n"),
    paste = "\n"
  )

  if (asis) {
    rv <- knitr::asis_output(rv)
  }
  rv
}

#' Verbose Logging
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' A family of wrappers of selected [`futile.logger`] functions that control
#' the logging mechanism in `crmPack`. The `crmPack` uses [`futile.logger`]
#' package for the logging purposes. All the messages logged in `crmPack` are
#' logged into `crmPack` logger at the [`futile.logger::TRACE`] level. Hence,
#' enabling verbose logging means that the logging threshold will be set to
#' [`futile.logger::TRACE`] for the `crmPack` logger, and disabling verbose
#' logging means that it will be set to [`futile.logger::FATAL`].
#'
#' @describeIn enable_logging A simple wrapper of
#'   [futile.logger::flog.threshold()] that enables `crmPack` verbose logging by
#'   setting logging threshold to [`futile.logger::TRACE`] for `crmPack` logger.
#'
#' @export
#'
enable_logging <- function() {
  invisible(
    futile.logger::flog.threshold(futile.logger::TRACE, name = "crmPack")
  )
}

#' @describeIn enable_logging A simple wrapper of
#'   [futile.logger::flog.threshold()] that disables `crmPack` verbose logging
#'   by setting logging threshold to [`futile.logger::FATAL`] for `crmPack`
#'   logger.
#'
#' @export
#'
disable_logging <- function() {
  invisible(
    futile.logger::flog.threshold(futile.logger::FATAL, name = "crmPack")
  )
}

#' @describeIn enable_logging A simple wrapper of
#'   [futile.logger::flog.logger()] that checks whether current threshold level
#'   for `crmPack` logger is verbose, which is [`futile.logger::TRACE`].
#'   It returns `TRUE` if the current logging level is verbose, `FALSE`
#'   otherwise.
#'
#' @export
#'
is_logging_enabled <- function() {
  logger <- futile.logger::flog.logger(name = "crmPack")
  unname(logger$threshold == futile.logger::TRACE)
}

#' @describeIn enable_logging A simple wrapper of
#'   [futile.logger::flog.trace()] that prints a log message in the `crmPack`
#'   logger.
#'
#' @inheritParams futile.logger::flog.trace
#'
#' @export
#'
log_trace <- function(msg, ..., capture = FALSE) {
  assert_string(msg)
  assert_flag(capture)

  futile.logger::flog.trace(msg = msg, ..., name = "crmPack", capture = capture)
}

#' @include helpers.R
NULL

#' Appending a Dummy Number for Selected Slots in Data
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' A helper function that appends a dummy value to a given slots in [`GeneralData`]
#' class object, if and only if the total number of observations (as indicated
#' by `object@nObs`) equals to `1`. Otherwise, the `object` is not changed.
#'
#' @note The main motivation behind this function is related to the `JAGS`.
#'   If there is only one observation, the data is not passed correctly to
#'   `JAGS`, i.e. e.g. `x` and `y` are treated like scalars in the data file.
#'   Therefore it is necessary to add dummy values to the vectors in this case
#'   As we don't change the number of observations (`nObs`), this addition of
#'   zeros doesn't affect the results of `JAGS` computations.
#'
#' @param object (`GeneralData`)\cr object into which dummy values will be added.
#' @param where (`character`)\cr names of slots in `object` to which a `dummy`
#'   number will be appended.
#' @param dummy (`number`)\cr a dummy number that will be appended to selected
#'   slots in `object`. Default to `0`.
#'
#' @return A [`GeneralData`] object with slots updated with dummy number.
#'
#' @export
#' @example examples/helpers-jags_add_dummy.R
#'
h_jags_add_dummy <- function(object, where, dummy = 0) {
  assert_class(object, "GeneralData")
  assert_character(where)
  assert_subset(where, slotNames(object))
  assert_number(dummy)

  if (object@nObs == 1L) {
    for (i in where) {
      # Add dummy value and preserve the class.
      slot(object, i) <- as(c(slot(object, i), dummy), class(slot(object, i)))
    }
  }
  object
}

#' Joining `JAGS` Models
#'
#' @description `r lifecycle::badge("stable")`
#'
#' This helper function joins two JAGS models in the way that the body of the
#' second model is appended to the body of the first model (in this order).
#' After that, the first, body-extended model is returned. The arguments of
#' `model1`, `model2` model functions (if any) are not combined in any way.
#'
#' @note `model1` and `model2` functions must have a multi-expression
#'   body, i.e. braced expression(s). Environments or any attributes of the
#'   function bodies are not preserved in any way after joining.
#'
#' @param model1 (`function`)\cr the first model to join.
#' @param model2 (`function`)\cr the second model to join.
#'
#' @return joined models.
#'
#' @export
#'
h_jags_join_models <- function(model1, model2) {
  assert_function(model1)
  assert_function(model2)
  assert_class(body(model1), "{")
  assert_class(body(model2), "{")

  # This workaround is needed to avoid bugs related to covr-injected code.
  if (h_covr_active()) {
    body(model2) <- h_covr_detrace(body(model2))
  }

  body2 <- as.list(body(model2))
  if (length(body2) >= 2) {
    body1 <- as.list(body(model1))
    body(model1) <- as.call(c(body1, body2[-1]))
  }
  model1
}


#' Setting Initial Values for `JAGS` Model Parameters
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' A simple helper function that prepares an object for `inits` argument of
#'   [rjags::jags.model()], which is invoked by [mcmc()] method. The `inits`
#'   argument specifies initial values for model parameters.
#'
#' @param model (`GeneralModel`)\cr an input model.
#' @param data (`GeneralData`)\cr an input data.
#'
#' @return A `list` of starting values for parameters required to be initialized
#'   in the MCMC `JAGS `sampler.
#'
#' @export
#' @example examples/helpers-jags_get_model_inits.R
#'
h_jags_get_model_inits <- function(model, data) {
  assert_class(model, "GeneralModel")
  assert_class(data, "GeneralData")

  inits <- do.call(model@init, h_slots(data, formalArgs(model@init)))
  assert_list(inits)
  inits[sapply(inits, length) > 0L]
}

#' Getting Data for `JAGS`
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' A simple helper function that prepares an object for `data` argument of
#'   [rjags::jags.model()], which is invoked by [mcmc()] method.
#'
#' @param model (`GeneralModel`)\cr an input model.
#' @param data (`GeneralData`)\cr an input data.
#' @param from_prior (`flag`)\cr sample from the prior only? In this case
#'   data will not be appended to the output, i.e. only the variables required
#'   by the `model@priormodel` model will be returned in data.
#'
#' @export
#' @example examples/helpers-jags_get_data.R
#'
h_jags_get_data <- function(model, data, from_prior) {
  assert_class(model, "GeneralModel")
  assert_class(data, "GeneralData")
  assert_flag(from_prior)

  # 1) Extract variables from `data` as required by `modelspecs`.
  ms_args_names <- formalArgs(model@modelspecs)
  ms_args <- if ("from_prior" %in% ms_args_names) {
    c(h_slots(data, setdiff(ms_args_names, "from_prior")), list(from_prior = from_prior))
  } else {
    h_slots(data, ms_args_names)
  }
  modelspecs <- do.call(model@modelspecs, ms_args)
  assert_list(modelspecs)

  # 2) Extract variables from `data` as required by `datanames`.
  datanames <- if (from_prior) {
    model@datanames_prior
  } else {
    union(model@datanames, model@datanames_prior)
  }

  # Add dummy to ensure that e.g. `x` and `y` in `data` won't be treated as
  # scalars by `JAGS` if `data@nObs == 1`, which leads to failures.
  add_where <- setdiff(datanames, c("nObs", "nGrid", "nObsshare", "yshare", "xshare", "Tmax"))
  data <- h_jags_add_dummy(data, where = add_where)

  data_model <- h_slots(data, datanames)
  c(data_model, modelspecs)
}

#' Writing JAGS Model to a File
#'
#' @description `r lifecycle::badge("stable")`
#'
#' This function converts a R function with JAGS model into a text and then
#' writes it into a given file. During the "model into text" conversion, the
#' format of numbers of which absolute value is less than `0.001` or greater
#' than `10000` is changed. These numbers will be converted into scientific
#' format with specified number of significant digits using [formatC()]
#' function.
#'
#' @note JAGS syntax allows truncation specification like `dnorm(...) I(...)`,
#'   which is illegal in R. To overcome this incompatibility, use dummy operator
#'   `\%_\%` before `I(...)`, i.e. `dnorm(...) \%_\% I(...)` in the model's
#'   code. This dummy operator `\%_\%` will be removed just before saving the
#'   JAGS code into a file.
#'   Due to technical issues related to conversion of numbers to scientific
#'   format, it is required that the body of a model function does not contain
#'   `TEMP_NUM_PREF_` or `_TEMP_NUM_SUF` character constants in its body.
#'
#' @param model (`function`)\cr function containing the JAGS model.
#' @param file (`string` or `NULL`)\cr the name of the file (including the
#'   optional path) where the model will be saved. If `NULL`, the file will be
#'   created in a `R_crmPack` folder placed under temporary directory indicated
#'   by [tempdir()] function.
#' @param digits (`count`)\cr a desired number of significant digits for
#'   for numbers used in JAGS input, see [formatC()].
#' @return The name of the file where the model was saved.
#'
#' @export
#' @example examples/helpers-jags_write_model.R
#'
h_jags_write_model <- function(model, file = NULL, digits = 5) {
  assert_function(model)
  assert_count(digits)

  # This workaround is needed to avoid bugs related to covr-injected code.
  if (h_covr_active()) {
    body(model) <- h_covr_detrace(body(model))
  }

  if (!is.null(file)) {
    assert_path_for_output(file)
  } else {
    dir <- file.path(tempdir(), "R_crmPack")
    # Don't warn, as the temp dir often exists (which is OK).
    dir.create(dir, showWarnings = FALSE)
    file <- tempfile(
      pattern = "jags_model_fun",
      tmpdir = dir,
      fileext = ".txt"
    )
  }

  # Replace scientific notation.
  model_sci_replaced <- h_rapply(
    x = body(model),
    fun = h_format_number,
    classes = c("integer", "numeric"),
    digits = digits,
    prefix = "TEMP_NUM_PREF_",
    suffix = "_TEMP_NUM_SUF"
  )
  # Transform `model` body into character vector.
  model_text <- deparse(model_sci_replaced, control = NULL)
  model_text <- gsub("\"TEMP_NUM_PREF_|_TEMP_NUM_SUF\"", "", model_text)
  model_text <- gsub("%_% ", "", model_text)
  model_text <- c("model", model_text)

  log_trace("Writting JAGS model function into: %s", file)
  writeLines(model_text, con = file)
  file
}

#' Extracting Samples from `JAGS` `mcarray` Object
#'
#' @description `r lifecycle::badge("stable")`
#'
#' A simple helper function that extracts a sample from
#'   [`rjags::mcarray.object`] S3 class object. The [`rjags::mcarray.object`]
#'   object is used by the [rjags::jags.samples()] function to represent MCMC
#'   output from a `JAGS` model.
#'
#' @param x an [`rjags::mcarray.object`] object.
#'
#' @export
#'
h_jags_extract_samples <- function(x) {
  assert_class(x, "mcarray")

  x <- x[, , 1L]
  # In case that there are multiple parameters in a node.
  if (is.matrix(x)) {
    x <- t(x)
  }
  x
}

#' Helper Function to Blind Plot Data
#'
#' @param df (`GeneralData`)\cr The data to be blinded
#' @param blind (`flag`)\cr Should the data be blinded?
#' @param has_placebo (`flag`)\cr Does the data contain a placebo dose?
#' @param pbo_dose (`positive_number`)\cr The dose to be taken as placebo.
#' Ignored if `has_placebo` is `FALSE`
#' @returns The blinded data
h_blind_plot_data <- function(df, blind, has_placebo, pbo_dose) {
  if (blind) {
    # This is to blind the data.
    # For each cohort, all DLTs are assigned to the first subjects in the cohort.
    # In addition, the placebo (if any) is set to the active dose level for that
    # cohort.
    # Notice: dapply reorders records of df according to the lexicographic order
    # of cohort.
    df <- dapply(df, f = ~cohort, FUN = function(coh) {
      coh$toxicity <- sort(coh$toxicity, decreasing = TRUE)
      coh$dose <- max(coh$dose)
      coh
    })
  } else if (has_placebo) {
    # Placebo will be plotted at y = 0 level.
    df$dose[df$dose == pbo_dose] <- 0
  }
  df
}

# h_plot_data_df ----

## generic ----

#' Helper Function for the Plot Method of subclasses of [`GeneralData`]
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' A method that transforms [`GeneralData`]  objects into a `tibble` suitable for
#' plotting with `ggplot2` methods
#'
#' @param data (`GeneralData`)\cr object from which data is extracted and converted
#' into a data frame.
#' @param ... further arguments passed to class-specific methods.
#' @return `data.frame` containing columns for patient, cohort, dose and toxicity grade
#' @aliases h_plot_data_df
#'
setGeneric(
  name = "h_plot_data_df",
  def = function(data, ...) standardGeneric("h_plot_data_df"),
  valueClass = "data.frame"
)

# Data ----

#' Helper Function for the Plot Method of [`Data`]
#'
#' @param data (`Data`)\cr object from which data is extracted and converted
#'   into a data frame.
#' @param blind (`flag`)\cr should data be blinded?
#'   If `TRUE`, then for each cohort, all DLTs are assigned to the first
#'   subjects in the cohort. In addition, the placebo (if any) is set to the
#'   active dose level for that cohort.
#' @param legend (`flag`)\cr Display the legend for the toxicity categories
#' @param ... further arguments passed to `data.frame` constructor.
#'   It can be e.g. an extra `column_name = value` pair based on a slot
#'   from `x` (which in this case might be a subclass of `Data`)
#'   which does not appear in `Data`.
#' @return A `data.frame` object with columns patient, ID, cohort, dose and
#' toxicity.
#' @describeIn h_plot_data_df method for [`Data`].
setMethod(
  f = "h_plot_data_df",
  signature = signature(data = "Data"),
  definition = function(data, blind = FALSE, legend = TRUE, ...) {
    df <- data.frame(
      patient = seq_along(data@x),
      ID = paste(" ", data@ID),
      cohort = data@cohort,
      dose = data@x,
      toxicity = ifelse(data@y == 1, "Yes", "No"),
      ...
    )
    df <- h_blind_plot_data(df, blind, data@placebo, data@doseGrid[1])
    df
  }
)

# DataOrdinal ----

#' Helper Function for the Plot Method of [`DataOrdinal`]
#'
#' @describeIn h_plot_data_df Class specific method for [`DataOrdinal`]
setMethod(
  f = "h_plot_data_df",
  signature = signature(data = "DataOrdinal"),
  definition = function(data, blind = FALSE, legend = TRUE, ...) {
    df <- data.frame(
      patient = seq_along(data@x),
      ID = paste(" ", data@ID),
      cohort = data@cohort,
      dose = data@x,
      toxicity = names(data@yCategories)[1 + data@y],
      ...
    )
    df <- h_blind_plot_data(df, blind, data@placebo, data@doseGrid[1])
    df
  }
)


# h_plot_data_dataordinal

## Data ----

#' Helper Function for the Plot Method of the Data and DataOrdinal Classes
#'
#' @description `r lifecycle::badge("stable")`
#'
#' A method that creates a plot for [`Data`]  and [`DataOrdinal`] objects.
#'
#' @note The default values of `tox_shapes` and `tox_labels` result in DLTs
#' being displayed as red triangles and other responses as black circles.
#' @return The [`ggplot2`] object.
#'
#' @rdname plot-Data
h_plot_data_dataordinal <- function(
    x,
    blind = FALSE,
    legend = TRUE,
    tox_labels = c(Yes = "red", No = "black"),
    tox_shapes = c(Yes = 17L, No = 16L),
    ...) {
  assert_flag(blind)
  assert_flag(legend)
  assert_character(tox_labels, any.missing = FALSE, unique = TRUE)
  assert_integer(tox_shapes, any.missing = FALSE, unique = TRUE)
  assert_true(length(tox_shapes) == length(tox_labels))
  assert_subset(x@y, as.integer(0:(length(tox_shapes) - 1)))
  if (x@nObs == 0L) {
    return()
  }
  df <- h_plot_data_df(x, blind, ...)

  p <- ggplot(df, aes(x = patient, y = dose)) +
    geom_point(aes(shape = toxicity, colour = toxicity), size = 3) +
    scale_colour_manual(
      name = "Toxicity",
      values = tox_labels,
      breaks = names(tox_labels),
      guide = guide_legend(reverse = TRUE)
    ) +
    scale_shape_manual(
      name = "Toxicity",
      values = tox_shapes,
      breaks = names(tox_shapes),
      guide = guide_legend(reverse = TRUE)
    ) +
    scale_x_continuous(breaks = df$patient, minor_breaks = NULL) +
    scale_y_continuous(
      breaks = sort(unique(c(0, df$dose))),
      minor_breaks = NULL,
      limits = c(0, max(df$dose) * 1.1)
    ) +
    xlab("Patient") +
    ylab("Dose Level")

  p <- p + h_plot_data_cohort_lines(df$cohort, placebo = x@placebo)

  if (!blind) {
    p <- p +
      geom_text(
        aes(label = ID, size = 2),
        data = df,
        hjust = 0,
        vjust = 0.5,
        angle = 90,
        colour = "black",
        show.legend = FALSE
      )
  }

  if (!legend) {
    p <- p + theme(legend.position = "none")
  }

  p
}

#' Helper Function Containing Common Functionality
#'
#' Used by `dose_grid_range-Data` and `dose_grid_range-DataOrdinal`
#' @param object (`Data` or `DataOrdinal`)\cr the object for which the dose grid
#' range is required
#' @param ignore_placebo (`flag`)\cr should placebo dose (if any) not be counted?
#'
h_obtain_dose_grid_range <- function(object, ignore_placebo) {
  assert_flag(ignore_placebo)

  dose_grid <- if (ignore_placebo && object@placebo && object@nGrid >= 1) {
    object@doseGrid[-1]
  } else {
    object@doseGrid
  }

  if (length(dose_grid) == 0L) {
    c(-Inf, Inf)
  } else {
    range(dose_grid)
  }
}

#' Convert a Ordinal Data to the Equivalent Binary Data for a Specific
#' Grade
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' A simple helper function that takes a [`DataOrdinal`] object and an
#' integer grade and converts them to the equivalent `Data` object.
#'
#' @param data_ord (`DataOrdinal`)\cr the `DataOrdinal` object to covert
#' @param grade (`integer`)\cr the toxicity grade for which the equivalent data
#' is required.
#' @return A [`Data`] object.
#'
#' @export
h_convert_ordinal_data <- function(data_ord, grade) {
  # Validate
  assert_integer(grade, len = 1, lower = 1)
  assert_class(data_ord, "DataOrdinal")
  # Execute
  Data(
    ID = data_ord@ID,
    cohort = data_ord@cohort,
    x = data_ord@x,
    y = as.integer(data_ord@y >= grade),
    doseGrid = data_ord@doseGrid,
    nGrid = data_ord@nGrid,
    xLevel = data_ord@xLevel,
    placebo = data_ord@placebo
  )
}

# nolint start

#####################################################################################
## Author: Daniel Sabanes Bove [sabanesd *a*t* roche *.* com]
## Project: Object-oriented implementation of CRM designs
##
## Time-stamp: <[fromQuantiles.R] by DSB Fre 19/06/2015 14:22>
##
## Description:
## Find the best LogisticNormal model for a given set of quantiles at certain
## dose levels
##
## History:
## 11/02/2014   file creation
#####################################################################################

##' @include helpers.R
##' @include Model-class.R
{}


##' Convert prior quantiles (lower, median, upper) to logistic (log)
##' normal model
##'
##' This function uses generalized simulated annealing to optimize
##' a \code{\linkS4class{LogisticNormal}} model to be as close as possible
##' to the given prior quantiles.
##'
##' @param dosegrid the dose grid
##' @param refDose the reference dose
##' @param lower the lower quantiles
##' @param median the medians
##' @param upper the upper quantiles
##' @param level the credible level of the (lower, upper) intervals (default:
##' 0.95)
##' @param logNormal use the log-normal prior? (not default) otherwise, the
##' normal prior for the logistic regression coefficients is used
##' @param parstart starting values for the parameters. By default, these
##' are determined from the medians supplied.
##' @param parlower lower bounds on the parameters (intercept alpha and the
##' slope beta, the corresponding standard deviations and the correlation.)
##' @param parupper upper bounds on the parameters
##' @param seed seed for random number generation
##' @param verbose be verbose? (default)
##' @param control additional options for the optimisation routine, see
##' \code{\link[GenSA]{GenSA}} for more details
##' @return a list with the best approximating \code{model}
##' (\code{\linkS4class{LogisticNormal}} or
##' \code{\linkS4class{LogisticLogNormal}}), the resulting \code{quantiles}, the
##' \code{required} quantiles and the \code{distance} to the required quantiles,
##' as well as the final \code{parameters} (which could be used for running the
##' algorithm a second time)
##'
##' @importFrom GenSA GenSA
##' @importFrom mvtnorm rmvnorm
##' @export
##' @keywords programming
Quantiles2LogisticNormal <- function(dosegrid,
                                     refDose,
                                     lower,
                                     median,
                                     upper,
                                     level = 0.95,
                                     logNormal = FALSE,
                                     parstart = NULL,
                                     parlower = c(-10, -10, 0, 0, -0.95),
                                     parupper = c(10, 10, 10, 10, 0.95),
                                     seed = 12345,
                                     verbose = TRUE,
                                     control =
                                       list(
                                         threshold.stop = 0.01,
                                         maxit = 50000,
                                         temperature = 50000,
                                         max.time = 600
                                       )) {
  ## extracts and checks
  nDoses <- length(dosegrid)

  assert_flag(logNormal)
  assert_flag(verbose)
  assert_probability(level, bounds_closed = FALSE)
  stopifnot(
    !is.unsorted(dosegrid, strictly = TRUE),
    ## the medians must be monotonically increasing:
    !is.unsorted(median),
    identical(length(lower), nDoses),
    identical(length(median), nDoses),
    identical(length(upper), nDoses),
    all(lower < median),
    all(upper > median),
    identical(length(parlower), 5L),
    identical(length(parupper), 5L),
    all(parlower < parstart),
    all(parstart < parupper)
  )

  ## put verbose argument in the control list
  control$verbose <- verbose

  ## parametrize in terms of the means for the intercept alpha and the
  ## (log) slope beta,
  ## the corresponding standard deviations and the correlation.
  ## Define start values for optimisation:
  startValues <-
    if (is.null(parstart)) {
      ## find approximate means for alpha and slope beta
      ## from fitting logistic model to medians:
      startAlphaBeta <-
        coef(lm(I(logit(median)) ~ I(log(dosegrid / refDose))))

      ## overall starting values:
      c(
        meanAlpha =
          startAlphaBeta[1],
        meanBeta =
          if (logNormal) log(startAlphaBeta[2]) else startAlphaBeta[2],
        sdAlpha =
          1,
        sdBeta =
          1,
        correlation =
          0
      )
    } else {
      parstart
    }

  ## what is the target function which we want to minimize?
  target <- function(param) {
    ## form the mean vector and covariance matrix
    mean <- param[1:2]
    cov <- matrix(
      c(
        param[3]^2,
        prod(param[3:5]),
        prod(param[3:5]),
        param[4]^2
      ),
      nrow = 2L, ncol = 2L
    )

    ## simulate from the corresponding normal distribution
    set.seed(seed)
    normalSamples <- mvtnorm::rmvnorm(
      n = 1e4L,
      mean = mean,
      sigma = cov
    )

    ## extract separate coefficients
    alphaSamples <- normalSamples[, 1L]
    betaSamples <- if (logNormal) exp(normalSamples[, 2L]) else normalSamples[, 2L]

    ## and compute resulting quantiles
    quants <- matrix(
      nrow = length(dosegrid),
      ncol = 3L
    )
    colnames(quants) <- c("lower", "median", "upper")

    ## process each dose after another:
    for (i in seq_along(dosegrid))
    {
      ## create samples of the probability
      probSamples <-
        plogis(alphaSamples + betaSamples * log(dosegrid[i] / refDose))

      ## compute lower, median and upper quantile
      quants[i, ] <-
        quantile(probSamples,
          probs = c((1 - level) / 2, 0.5, (1 + level) / 2)
        )
    }

    ## now we can compute the target value
    ret <- max(abs(quants - c(lower, median, upper)))
    return(structure(ret,
      mean = mean,
      cov = cov,
      quantiles = quants
    ))
  }

  set.seed(seed)
  ## now optimise the target
  genSAres <- GenSA::GenSA(
    par = startValues,
    fn = target,
    lower = parlower,
    upper = parupper,
    control = control
  )
  distance <- genSAres$value
  pars <- genSAres$par
  targetRes <- target(pars)

  ## and construct the model
  ret <-
    if (logNormal) {
      LogisticLogNormal(
        mean = attr(targetRes, "mean"),
        cov = attr(targetRes, "cov"),
        ref_dose = refDose
      )
    } else {
      LogisticNormal(
        mean = attr(targetRes, "mean"),
        cov = attr(targetRes, "cov"),
        ref_dose = refDose
      )
    }

  ## return it together with the resulting distance and the quantiles
  return(list(
    model = ret,
    parameters = pars,
    quantiles = attr(targetRes, "quantiles"),
    required = cbind(lower, median, upper),
    distance = distance
  ))
}

##' Get the minimal informative unimodal beta distribution
##'
##' As defined in Neuenschwander et al (2008), this function computes the
##' parameters of the minimal informative unimodal beta distribution, given the
##' request that the p-quantile should be q, i.e. X ~ Be(a, b) with Pr(X <= q) =
##' p.
##'
##' @param p the probability (> 0 and < 1)
##' @param q the quantile (> 0 and < 1)
##' @return the two resulting beta parameters a and b in a list
##'
##' @export
##' @keywords programming
getMinInfBeta <- function(p, q) {
  assert_probability(p, bounds_closed = FALSE)
  assert_probability(q, bounds_closed = FALSE)

  ret <-
    if (q > p) {
      list(
        a = log(p) / log(q),
        b = 1
      )
    } else {
      list(
        a = 1,
        b = log(1 - p) / log(1 - q)
      )
    }

  return(ret)
}


##' Construct a minimally informative prior
##'
##' This function constructs a minimally informative prior, which is captured in
##' a \code{\linkS4class{LogisticNormal}} (or
##' \code{\linkS4class{LogisticLogNormal}}) object.
##'
##' Based on the proposal by Neuenschwander et al (2008, Statistics in
##' Medicine), a minimally informative prior distribution is constructed. The
##' required key input is the minimum (\eqn{d_{1}} in the notation of the
##' Appendix A.1 of that paper) and the maximum value (\eqn{d_{J}}) of the dose
##' grid supplied to this function. Then \code{threshmin} is the probability
##' threshold \eqn{q_{1}}, such that any probability of DLT larger than
##' \eqn{q_{1}} has only 5% probability. Therefore \eqn{q_{1}} is the 95%
##' quantile of the beta distribution and hence \eqn{p_{1} = 0.95}. Likewise,
##' \code{threshmax} is the probability threshold \eqn{q_{J}}, such that any
##' probability of DLT smaller than \eqn{q_{J}} has only 5% probability
##' (\eqn{p_{J} = 0.05}). The probabilities \eqn{1 - p_{1}} and \eqn{p_{J}} can be
##' controlled with the arguments \code{probmin} and \code{probmax}, respectively.
##' Subsequently, for all doses supplied in the
##' \code{dosegrid} argument, beta distributions are set up from the assumption
##' that the prior medians are linear in log-dose on the logit scale, and
##' \code{\link{Quantiles2LogisticNormal}} is used to transform the resulting
##' quantiles into an approximating \code{\linkS4class{LogisticNormal}} (or
##' \code{\linkS4class{LogisticLogNormal}}) model. Note that the reference dose
##' is not required for these computations.
##'
##' @param dosegrid the dose grid
##' @param refDose the reference dose
##' @param threshmin Any toxicity probability above this threshold would
##' be very unlikely (see \code{probmin}) at the minimum dose (default: 0.2)
##' @param threshmax Any toxicity probability below this threshold would
##' be very unlikely (see \code{probmax}) at the maximum dose (default: 0.3)
##' @param probmin the prior probability of exceeding \code{threshmin} at the
##' minimum dose (default: 0.05)
##' @param probmax the prior probability of being below \code{threshmax} at the
##' maximum dose (default: 0.05)
##' @param \dots additional arguments for computations, see
##' \code{\link{Quantiles2LogisticNormal}}, e.g. \code{refDose} and
##' \code{logNormal=TRUE} to obtain a minimal informative log normal prior.
##' @return see \code{\link{Quantiles2LogisticNormal}}
##'
##' @example examples/MinimalInformative.R
##' @export
##' @keywords programming
MinimalInformative <- function(dosegrid,
                               refDose,
                               threshmin = 0.2,
                               threshmax = 0.3,
                               probmin = 0.05,
                               probmax = 0.05,
                               ...) {
  ## extracts and checks
  nDoses <- length(dosegrid)

  assert_probability(threshmin, bounds_closed = FALSE)
  assert_probability(threshmax, bounds_closed = FALSE)
  assert_probability(probmin, bounds_closed = FALSE)
  assert_probability(probmax, bounds_closed = FALSE)
  stopifnot(
    !is.unsorted(dosegrid, strictly = TRUE)
  )
  xmin <- dosegrid[1]
  xmax <- dosegrid[nDoses]

  ## derive the beta distributions at the lowest and highest dose
  betaAtMin <- getMinInfBeta(
    q = threshmin,
    p = 1 - probmin
  )
  betaAtMax <- getMinInfBeta(
    q = threshmax,
    p = probmax
  )

  ## get the medians of those beta distributions
  medianMin <- with(
    betaAtMin,
    qbeta(p = 0.5, a, b)
  )
  medianMax <- with(
    betaAtMax,
    qbeta(p = 0.5, a, b)
  )

  ## now determine the medians of all beta distributions
  beta <- (logit(medianMax) - logit(medianMin)) / (log(xmax) - log(xmin))
  alpha <- logit(medianMax) - beta * log(xmax / refDose)
  medianDosegrid <- plogis(alpha + beta * log(dosegrid / refDose))

  ## finally for all doses calculate 95% credible interval bounds
  ## (lower and upper)
  lower <- upper <- dosegrid
  for (i in seq_along(dosegrid))
  {
    ## get min inf beta distribution
    thisMinBeta <- getMinInfBeta(
      p = 0.5,
      q = medianDosegrid[i]
    )

    ## derive required quantiles
    lower[i] <- with(
      thisMinBeta,
      qbeta(p = 0.025, a, b)
    )
    upper[i] <- with(
      thisMinBeta,
      qbeta(p = 0.975, a, b)
    )
  }

  ## now go to Quantiles2LogisticNormal
  Quantiles2LogisticNormal(
    dosegrid = dosegrid,
    refDose = refDose,
    lower = lower,
    median = medianDosegrid,
    upper = upper,
    level = 0.95,
    ...
  )
}

# nolint end

# assertions ----

#' Additional Assertions for `checkmate`
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' We provide additional assertion functions that can be used together with
#' the `checkmate` functions. These are described in individual help pages
#' linked below.
#'
#' @return Depending on the function prefix.
#' - `assert_` functions return the object invisibly if successful, and otherwise
#'   throw an error message.
#' - `check_` functions return `TRUE` if successful, otherwise a string with the
#'   error message.
#' - `test_` functions just return `TRUE` or `FALSE`.
#'
#' @seealso [assert_probabilities()], [assert_probability()],
#'   [assert_probability_range()], [assert_length()].
#'
#' @name assertions
NULL

# check equality ----

#' Check if All Arguments Are Equal
#'
#' @description `r lifecycle::badge("experimental")`
#' Elements of `...` must be numeric vectors or scalars.
#'
#' This function performs an element-by-element comparison of the first object
#' provided in `...` with every other object in `...` and returns `TRUE` if all
#' comparisons are equal within a given tolerance and `FALSE` otherwise.
#'
#' @param ... (`numeric`)\cr vectors to be compared.
#' @param tol (`numeric`)\cr the maximum difference to be tolerated when
#' judging equality.
#'
#' @note If there are any missing or infinite values in `...`, this function
#'   returns `FALSE`, regardless of the values of other elements in `...`.
#'
#' @note If elements in `...` are not all of the same length, `FALSE` is returned.
#'
#' @return `TRUE` if all element-by-element differences are less than `tolerance`
#' in magnitude, `FALSE` otherwise.
#' @seealso [`assertions`] for more details.
#'
#' @export
#' @examples
#' check_equal(1:2, 1:2) # TRUE
#' check_equal(1:2, 2:3) # "Not all equal"
#' check_equal(Inf, Inf) # "Not all equal"
#' check_equal(0.01, 0.02) # "Not all equal"
#' check_equal(0.01, 0.02, tol = 0.05) # TRUE
#' check_equal(1, c(1, 1)) # "Not all equal"
check_equal <- function(..., tol = sqrt(.Machine$double.eps)) {
  dot_args <- list(...)

  sapply(dot_args, assert_numeric)

  tmp <- sapply(dot_args, length)
  if (min(tmp) != max(tmp)) {
    return("Not all of same length")
  }
  if (any(sapply(dot_args, is.na))) {
    return("Some entries NA")
  }
  if (any(sapply(dot_args, is.infinite))) {
    return("Not all entries finite")
  }
  if (!all(sapply(dot_args, test_numeric))) {
    return("Not all numeric")
  }

  all_ok <- test_true(
    all(
      sapply(
        2:length(dot_args),
        function(z) abs(dot_args[[1]] - dot_args[[z]]) < tol
      )
    )
  )
  if (all_ok) {
    return(TRUE)
  }
  "Not all equal"
}

#' Assert That All Arguments Are Equal
#'
#' @description `r lifecycle::badge("experimental")`
#' Elements of `...` must be numeric vectors or scalars.
#'
#' This function performs an element-by-element comparison of the first object
#' provided in `...` with every other object in `...` and throws an error if they
#' are not.
#'
#' @param ... (`numeric`)\cr vectors to be compared
#' @param tol (`numeric`)\cr the maximum difference to be tolerated when
#' judging equality
#'
#' @note If there are any missing or infinite values in `...`, this function
#'   throws an error, regardless of the values of other elements in `...`.
#'
#' @note If elements in `...` are not all of the same length, an error is thrown.
#'
#' @return `list(...)`, invisibly.
#' @seealso [`assertions`] for more details.
#' @inheritParams checkmate::assert_numeric
#'
#' @export
#' @rdname check_equal
#' @examples
#' assert_equal(1:2, 1:2) # no error
#' assert_equal(0.01, 0.02, tol = 0.05) # no error
# nolint start
assert_equal <- function(..., tol = sqrt(.Machine$double.eps), .var.name = vname(x), add = NULL) {
  # assert_equal <- makeAssertionFunction(check_equal) fails with error "Error
  # in `checkmate::makeAssertion(..., res, .var.name, add)`: unused argument
  # (add)", possibly because of the use of ... in check_equal.
  res <- check_equal(..., tol = tol)
  makeAssertion(list(...), res, .var.name, add)
}
# nolint end

# assert_probabilities ----

#' Check if an argument is a probability vector
#'
#' @description `r lifecycle::badge("stable")`
#'
#' Check if every element in a given numerical vector or matrix represents a
#' probability, that is a number within (0, 1) interval, that can optionally be
#' closed at any side.
#'
#' @note If there are any missing or non-finite values in `x`, this function
#'   returns `FALSE`, regardless of the values of other elements in `x`.
#'
#' @param x (`numeric`)\cr vector or matrix with numerical values to check.
#' @param bounds_closed (`logical`)\cr should bounds be closed? This can be a
#'   scalar or vector of length two. If it is a scalar, then its value applies
#'   equally to lower bound \eqn{0} and upper bound \eqn{1}. If this is a vector
#'   with two flags, the first flag corresponds to the lower bound \eqn{0}
#'   only, and the second to the upper bound \eqn{1} only.
#' @inheritParams checkmate::check_numeric
#'
#' @return `TRUE` if successful, otherwise a string with the error message.
#'
#' @seealso [`assertions`] for more details.
#'
#' @export
#' @examples
#' x <- c(0, 0.2, 0.1, 0.3, 1)
#' check_probabilities(x)
#' check_probabilities(x, bounds_closed = FALSE)
#' check_probabilities(x, bounds_closed = c(FALSE, TRUE))
check_probabilities <- function(x, bounds_closed = TRUE, len = NULL, unique = FALSE, sorted = FALSE) {
  assert_numeric(x)
  assert_logical(bounds_closed, min.len = 1, max.len = 2, any.missing = FALSE)
  assert_number(len, null.ok = TRUE)
  assert_flag(sorted)

  result <- check_numeric(
    x,
    finite = TRUE, any.missing = FALSE, len = len, unique = unique, sorted = sorted
  )

  if (isTRUE(result)) {
    in_bounds <- all(h_in_range(x, range = c(0L, 1L), bounds_closed = bounds_closed))
    if (!in_bounds) {
      result <- paste(
        "Probability must be within",
        ifelse(bounds_closed[1], "[0,", "(0,"),
        ifelse(tail(bounds_closed, 1), "1]", "1)"),
        "bounds but it is not"
      )
    }
  }

  result
}

#' @rdname check_probabilities
#' @inheritParams check_probabilities
#' @export
assert_probabilities <- makeAssertionFunction(check_probabilities)

#' @rdname check_probabilities
#' @inheritParams check_probabilities
#' @export
test_probabilities <- makeTestFunction(check_probabilities)

#' @rdname check_probabilities
#' @inheritParams check_probabilities
#' @export
expect_probabilities <- makeExpectationFunction(check_probabilities)

# assert_probability ----

#' Check if an argument is a single probability value
#'
#' @description `r lifecycle::badge("stable")`
#'
#' Check if a given value represents a probability, that is a number within
#' (0, 1) interval, that can optionally be closed at any side.
#'
#' @param x (`number`)\cr a single value to check.
#' @inheritParams check_probabilities
#'
#' @return `TRUE` if successful, otherwise a string with the error message.
#'
#' @seealso [`assertions`] for more details.
#'
#' @export
#' @examples
#' check_probability(0.5)
#' check_probability(0, bounds_closed = FALSE)
#' check_probability(0, bounds_closed = c(FALSE, TRUE))
check_probability <- function(x, bounds_closed = TRUE) {
  check_probabilities(x = x, bounds_closed = bounds_closed, len = 1)
}

#' @rdname check_probability
#' @inheritParams check_probability
#' @export
assert_probability <- makeAssertionFunction(check_probability)

#' @rdname check_probability
#' @inheritParams check_probability
#' @export
test_probability <- makeTestFunction(check_probability)

#' @rdname check_probability
#' @inheritParams check_probability
#' @export
expect_probability <- makeExpectationFunction(check_probability)

# assert_probability_range ----

#' Check if an argument is a probability range
#'
#' @description `r lifecycle::badge("stable")`
#'
#' Check if a given numerical interval represents a probability range, that is
#' a sub-interval of (0, 1) interval, that can optionally be closed at any side.
#'
#' @param x (`number`)\cr an interval to check.
#' @inheritParams check_probabilities
#'
#' @return `TRUE` if successful, otherwise a string with the error message.
#'
#' @seealso [`assertions`] for more details.
#'
#' @export
#' @examples
#' x <- c(0, 0.2)
#' check_probability_range(x)
#' check_probability_range(rev(x))
#' check_probability_range(x, bounds_closed = FALSE)
#' check_probability_range(x, bounds_closed = c(FALSE, TRUE))
check_probability_range <- function(x, bounds_closed = TRUE) {
  check_probabilities(x = x, bounds_closed = bounds_closed, len = 2, sorted = TRUE)
}

#' @rdname check_probability_range
#' @inheritParams check_probability_range
#' @export
assert_probability_range <- makeAssertionFunction(check_probability_range)

#' @rdname check_probability_range
#' @inheritParams check_probability_range
#' @export
test_probability_range <- makeTestFunction(check_probability_range)

#' @rdname check_probability_range
#' @inheritParams check_probability_range
#' @export
expect_probability_range <- makeExpectationFunction(check_probability_range)

# assert_length ----

#' Check if vectors are of compatible lengths
#'
#' @description `r lifecycle::badge("stable")`
#'
#' Two vectors are of compatible size if and only if: \cr
#' 1. At least one vector has size 1 \cr
#' 2. or both vectors are of the same size. \cr
#'
#' @param x (`any`)\cr the first vector, any object for which [length()]
#'   function is defined.
#' @param len (`count`)\cr the length of the second vector.
#' @inheritParams checkmate::check_numeric
#'
#' @return `TRUE` if successful, otherwise a string with the error message.
#'
#' @seealso [`assertions`] for more details.
#'
#' @export
#' @examples
#' check_length(1:5, 1)
#' check_length(1:5, 6)
#' check_length(1:5, 5)
#' check_length(10, 1)
#' check_length(10, 9)
check_length <- function(x, len) {
  x_len <- length(x)
  assert_true(x_len >= 1L)
  assert_count(len)

  if (x_len == 1L || len == 1L || x_len == len) {
    TRUE
  } else {
    paste(
      "x is of length",
      x_len,
      "which is not allowed; the allowed lengths are: 1 or",
      len,
      collapse = ""
    )
  }
}

#' @rdname check_length
#' @inheritParams check_length
#' @export
assert_length <- makeAssertionFunction(check_length)

#' @rdname check_length
#' @inheritParams check_length
#' @export
test_length <- makeTestFunction(check_length)

# assert_range ----

#' Check that an argument is a numerical range
#'
#' @description `r lifecycle::badge("stable")`
#'
#' An argument `x` is a numerical range if and only if (all conditions must be met):
#' 1. Is an object of type: `integer` or `double`.
#' 2. Is a vector or length two such that the value of the first number is not
#' less than the second number. Equalness is allowed if and only if `unique` flag
#' is set to `TRUE`.
#' 3. Lower bound of the interval is greater than or equal to `lower` and
#' upper bound of the interval is less than or equal to `upper`.
#' 4. It contains only finite (given that `finite` is `TRUE`) and non-missing values.
#'
#' @inheritParams checkmate::check_numeric
#'
#' @return `TRUE` if successful, otherwise a string with the error message.
#'
#' @seealso [`assertions`] for more details.
#'
#' @export
#' @examples
#' check_range(c(1, 5))
#' check_range(c(-5, 1))
#' check_range(c(4, 1))
#' check_range(c(1, 1))
#' check_range(c(1, 1), unique = FALSE)
#' check_range(1:3)
check_range <- function(x, lower = -Inf, upper = Inf, finite = FALSE, unique = TRUE) {
  assert_number(lower)
  assert_number(upper)
  assert_flag(finite)
  assert_flag(unique)

  result <- check_numeric(
    x,
    lower = lower,
    upper = upper,
    finite = finite,
    any.missing = FALSE,
    len = 2,
    unique = unique,
    sorted = TRUE
  )

  if (!isTRUE(result)) {
    result <- paste("x must be a valid numerical range.", result)
  }
  result
}

#' @rdname check_range
#' @inheritParams check_range
#' @export
assert_range <- makeAssertionFunction(check_range)

#' @rdname check_range
#' @inheritParams check_range
#' @export
test_range <- makeTestFunction(check_range)

#' @rdname check_range
#' @inheritParams check_range
#' @export
expect_range <- makeExpectationFunction(check_range)

# for nextBest methods ----

## some specific helpers ----

#' Calculating the Information Theoretic Distance
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' Helper function which provides the value of the
#' divergence as given by equation in (7) in the reference at
#' https://doi.org/10.1002/sim.8450.
#'
#' @param prob (`numeric`)\cr vector or matrix with probabilities of a DLT occurring.
#' @param target (`number `)\cr single target probability of a DLT.
#' @param asymmetry (`number`)\cr describes the rate of penalization
#'   for overly toxic does, range 0 to 2.
#'
#' @export
#' @examples
#' h_info_theory_dist(c(0.5, 0.2), 0.4, 1.2)
h_info_theory_dist <- function(prob, target, asymmetry) {
  assert_probabilities(prob)
  assert_true(test_vector(prob) || test_matrix(prob))
  assert_number(target, finite = TRUE)
  assert_number(asymmetry, lower = 0, upper = 2)

  ((prob - target)^2) / (((prob^asymmetry) * (1 - prob)^(2 - asymmetry)))
}

#' Credibility Intervals for Max Gain and Target Doses at `nextBest-NextBestMaxGain` Method.
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' Helper function for [`nextBest-NextBestMaxGain()`] method. It computes a
#' 95% credibility intervals for given target dose and max gain dose.
#' It also returns a ratio of upper and lower bounds of the interval.
#'
#' @param dose_target (`number`)\cr target dose estimate.
#' @param dose_mg (`number`)\cr the dose corresponding to the maximum gain.
#' @param prob_target (`proportion`)\cr target DLT probability.
#' @param placebo (`flag`)\cr if `TRUE` the first dose level in the dose grid used
#'   is considered as placebo. This is needed to adjust the max gain dose using
#'   efficacy constant value. If the `placebo` was used, then the `model_eff@const`
#'   is added to `dose_mg`.
#' @param model (`ModelTox`)\cr the DLT model.
#' @param model_eff (`Effloglog`)\cr the efficacy model.
#'
#' @references
#'   Yeung, W.Y., Whitehead, J., Reigner, B., Beyer, U., Diack, Ch., Jaki, T. (2015),
#'   Bayesian adaptive dose-escalation procedures for binary and continuous responses utilizing a gain function,
#'   *Pharmaceutical Statistics*,
#'   \doi{10.1002/pst.1706} \cr
#'
#' @export
#'
h_next_best_mg_ci <- function(dose_target,
                              dose_mg,
                              prob_target,
                              placebo,
                              model,
                              model_eff) {
  assert_number(dose_target, na.ok = TRUE)
  assert_number(dose_mg, na.ok = TRUE)
  assert_probability(prob_target)
  assert_flag(placebo)
  assert_class(model, "ModelTox")
  assert_class(model_eff, "Effloglog")

  # Find the variance of the log of target dose.
  mat <- matrix(
    c(
      -1 / (model@phi2),
      -(log(prob_target / (1 - prob_target)) - model@phi1) / (model@phi2)^2
    ),
    nrow = 1
  )
  var_dose_target <- as.vector(mat %*% model@Pcov %*% t(mat))

  # 95% credibility interval for target dose.
  ci_dose_target <- exp(log(dose_target) + c(-1, 1) * 1.96 * sqrt(var_dose_target))
  cir_dose_target <- ci_dose_target[2] / ci_dose_target[1]

  # Find the variance of the log of dose_mg.
  # First, find the covariance matrix of all the parameters, phi1, phi2, theta1 and theta2
  # given that phi1 and phi2 are independent of theta1 and theta2.
  log_dose_mg <- log(dose_mg + ifelse(placebo, model_eff@const, 0))

  # Find a delta_g matrix for a variance according to Yeung et. al (2015).
  mean_eff_mg <- model_eff@theta1 + model_eff@theta2 * log(log_dose_mg)
  denom <- model@phi2 * mean_eff_mg * (1 + model@phi2 * log_dose_mg)
  dgphi1 <- -(mean_eff_mg * log_dose_mg * model@phi2 - model_eff@theta2) / denom
  dgphi2 <- -(log_dose_mg * (mean_eff_mg * (1 + log_dose_mg * model@phi2) - model_eff@theta2)) / denom
  dgtheta1 <- -(log_dose_mg * model@phi2) / denom
  dgtheta2_num <- -(exp(model@phi1 + model@phi2 * log_dose_mg) * (model@phi2 * log_dose_mg * log(log_dose_mg) - 1) - 1)
  dgtheta2 <- dgtheta2_num / denom
  delta_g <- matrix(c(dgphi1, dgphi2, dgtheta1, dgtheta2), 4, 1)

  zero_matrix <- matrix(0, 2, 2)
  cov_beta <- cbind(rbind(model@Pcov, zero_matrix), rbind(zero_matrix, model_eff@Pcov))
  var_log_dose_mg <- as.vector(t(delta_g) %*% cov_beta %*% delta_g)

  # 95% credibility interval for max gain dose.
  ci_mg <- exp(log_dose_mg + c(-1, 1) * 1.96 * sqrt(var_log_dose_mg))
  ci_ratio_mg <- ci_mg[2] / ci_mg[1]

  list(
    ci_dose_target = ci_dose_target,
    ci_ratio_dose_target = cir_dose_target,
    ci_dose_mg = ci_mg,
    ci_ratio_dose_mg = ci_ratio_mg
  )
}

## next best at grid ----

#' Get Closest Grid Doses for a Given Target Doses for `nextBest-NextBestMaxGain` Method.
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' Helper function that for a given target doses finds the dose in grid that is
#' closest and below the target. There are four different targets in the context
#' of [`nextBest-NextBestMaxGain()`] method: \eqn{min(`dose_mg`, `dose_target_drt`)},
#' `dose_mg`, `dose_target_drt` or `dose_target_eot`.
#'
#' @param dose_target_drt (`number`)\cr target dose estimate during the trial.
#' @param dose_target_eot (`number`)\cr target dose estimate at the end of the trial.
#' @param dose_mg (`number`)\cr the dose corresponding to the maximum gain.
#' @param dose_grid (`numeric`)\cr all possible doses.
#' @param doselimit (`number`)\cr the maximum allowed next dose.
#' @param placebo (`flag`)\cr if `TRUE` the first dose level in the `dose_grid`
#'   is considered as placebo.
#'
#' @export
#'
h_next_best_mg_doses_at_grid <- function(dose_target_drt,
                                         dose_target_eot,
                                         dose_mg,
                                         dose_grid,
                                         doselimit,
                                         placebo) {
  assert_number(dose_target_drt, na.ok = TRUE)
  assert_number(dose_target_eot, na.ok = TRUE)
  assert_number(dose_mg, na.ok = TRUE)

  doses_eligible <- h_next_best_eligible_doses(dose_grid, doselimit, placebo)

  # h_find_interval assumes that elements in doses_eligible are strictly increasing.
  next_dose_lev <- h_find_interval(min(dose_mg, dose_target_drt), doses_eligible)
  next_dose <- doses_eligible[next_dose_lev]

  next_dose_mg_lev <- h_find_interval(dose_mg, doses_eligible)
  next_dose_mg <- doses_eligible[next_dose_mg_lev]

  next_dose_lev_drt <- h_find_interval(dose_target_drt, doses_eligible)
  next_dose_drt <- doses_eligible[next_dose_lev_drt]

  next_dose_lev_eot <- h_find_interval(dose_target_eot, doses_eligible)
  next_dose_eot <- doses_eligible[next_dose_lev_eot]

  next_dose_list <- list(
    next_dose = next_dose,
    next_dose_drt = next_dose_drt,
    next_dose_eot = next_dose_eot,
    next_dose_mg = next_dose_mg
  )
}

## eligible doses ----

#' Get Eligible Doses from the Dose Grid.
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' Helper function that gets the eligible doses from the dose grid.
#' The eligible doses are the doses which do not exceed a given
#' `doselimit`. For placebo design, if safety allows (i.e. if there is at least
#' one non-placebo dose which does not exceed the dose limit), the placebo dose
#' it then excluded from the eligible doses.
#'
#' @param dose_grid (`numeric`)\cr all possible doses.
#' @param doselimit (`number`)\cr the maximum allowed next dose.
#' @param placebo (`flag`)\cr if `TRUE` the first dose level in the `dose_grid`
#'   is considered as placebo.
#' @param levels (`flag`)\cr if `TRUE` the levels of eligible doses are returned,
#'   otherwise, the doses (default).
#'
#' @return A numeric vector with eligible doses or eligible dose levels if `levels`
#'   flag is `TRUE`.
#'
#' @export
#' @examples
#' dose_grid <- c(0.001, seq(25, 200, 25))
#' h_next_best_eligible_doses(dose_grid, 79, TRUE)
#' h_next_best_eligible_doses(dose_grid, 24, TRUE)
h_next_best_eligible_doses <- function(dose_grid,
                                       doselimit,
                                       placebo,
                                       levels = FALSE) {
  assert_numeric(dose_grid, finite = TRUE, any.missing = FALSE, min.len = 1L, sorted = TRUE)
  assert_number(doselimit)
  assert_flag(placebo)
  assert_flag(levels)

  is_dose_eligible <- dose_grid <= doselimit
  if (placebo && sum(is_dose_eligible) > 1L) {
    is_dose_eligible[1] <- FALSE
  }

  if (levels) {
    is_dose_eligible
  } else {
    dose_grid[is_dose_eligible]
  }
}

## plot ----

#' Building the Plot for `nextBest-NextBestNCRMLoss` Method.
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' Helper function which creates the plot for [`nextBest-NextBestNCRMLoss()`]
#' method.
#'
#' @param prob_mat (`numeric`)\cr matrix with probabilities of a grid doses
#'   to be in a given interval. If `is_unacceptable_specified` is `TRUE`, there
#'   must be 4 intervals (columns) in `prob_mat`: `underdosing`, `target`,
#'   `excessive`, `unacceptable`. Otherwise, there must be 3 intervals (columns):
#'   `underdosing`, `target`, `overdose`. Number of rows must be equal to number
#'   of doses in a grid.
#' @param posterior_loss (`numeric`)\cr posterior losses.
#' @param max_overdose_prob (`number`)\cr maximum overdose posterior
#'   probability that is allowed.
#' @param dose_grid (`numeric`)\cr dose grid.
#' @param max_eligible_dose_level (`number`)\cr maximum eligible dose level in
#'   the `dose_grid`.
#' @param doselimit (`number`)\cr the maximum allowed next dose.
#' @param next_dose (`number`)\cr next best dose.
#' @param is_unacceptable_specified (`flag`)\cr is unacceptable interval specified?
#'
#' @export
h_next_best_ncrm_loss_plot <- function(prob_mat,
                                       posterior_loss,
                                       max_overdose_prob,
                                       dose_grid,
                                       max_eligible_dose_level,
                                       doselimit,
                                       next_dose,
                                       is_unacceptable_specified) {
  assert_numeric(dose_grid, finite = TRUE, any.missing = FALSE, sorted = TRUE)
  n_grid <- length(dose_grid)
  assert_flag(is_unacceptable_specified)
  assert_probabilities(prob_mat)
  assert_matrix(prob_mat, min.cols = 3, max.cols = 4, nrows = n_grid, col.names = "named")
  if (!is_unacceptable_specified) {
    assert_names(colnames(prob_mat), permutation.of = c("underdosing", "target", "overdose"))
  } else {
    assert_names(colnames(prob_mat), permutation.of = c("underdosing", "target", "excessive", "unacceptable"))
  }
  assert_numeric(posterior_loss, finite = TRUE, any.missing = FALSE, len = n_grid)
  assert_probability(max_overdose_prob)
  assert_number(max_eligible_dose_level, lower = 0, upper = n_grid)
  assert_number(doselimit)
  assert_number(next_dose, na.ok = TRUE)

  # Build plots, first for the target probability.
  p1 <- ggplot() +
    geom_bar(
      data = data.frame(Dose = dose_grid, y = prob_mat[, "target"] * 100),
      aes(x = .data$Dose, y = .data$y),
      stat = "identity",
      position = "identity",
      width = min(diff(dose_grid)) / 2,
      colour = "darkgreen",
      fill = "darkgreen"
    ) +
    ylim(c(0, 100)) +
    ylab(paste("Target probability [%]"))

  if (is.finite(doselimit)) {
    p1 <- p1 + geom_vline(xintercept = doselimit, lwd = 1.1, lty = 2, colour = "black")
  }

  if (max_eligible_dose_level > 0) {
    p1 <- p1 +
      geom_vline(xintercept = dose_grid[max_eligible_dose_level], lwd = 1.1, lty = 2, colour = "red")
  }

  p_loss <- ggplot() +
    # For the loss function.
    geom_bar(
      data = data.frame(Dose = dose_grid, y = posterior_loss),
      aes(x = .data$Dose, y = .data$y),
      stat = "identity",
      position = "identity",
      width = min(diff(dose_grid)) / 2,
      colour = "darkgreen",
      fill = "darkgreen"
    ) +
    geom_point(
      aes(x = next_dose, y = max(posterior_loss) + 0.2),
      size = 3,
      pch = 25,
      col = "red",
      bg = "red"
    ) +
    ylab(paste("Loss function"))

  if (!is_unacceptable_specified) {
    # Second, for the overdosing probability.
    p2 <- ggplot() +
      geom_bar(
        data = data.frame(Dose = dose_grid, y = prob_mat[, "overdose"] * 100),
        aes(x = .data$Dose, y = .data$y),
        stat = "identity",
        position = "identity",
        width = min(diff(dose_grid)) / 2,
        colour = "red",
        fill = "red"
      ) +
      geom_hline(
        yintercept = max_overdose_prob * 100, lwd = 1.1, lty = 2,
        colour = "black"
      ) +
      ylim(c(0, 100)) +
      ylab("Overdose probability [%]")

    # Combine it all together.
    plots_single <- list(plot1 = p1, plot2 = p2, plot_loss = p_loss)
    plot_joint <- gridExtra::arrangeGrob(p1, p2, p_loss, nrow = 3)
  } else {
    # Plot in case of 4 toxicity intervals. Second, for the overdosing probability.
    p2 <- ggplot() +
      geom_bar(
        data = data.frame(Dose = dose_grid, y = prob_mat[, "excessive"] * 100),
        aes(x = .data$Dose, y = .data$y),
        stat = "identity",
        position = "identity",
        width = min(diff(dose_grid)) / 2,
        colour = "red",
        fill = "red"
      ) +
      ylim(c(0, 100)) +
      ylab("Excessive probability [%]")

    p3 <- ggplot() +
      geom_bar(
        data = data.frame(Dose = dose_grid, y = prob_mat[, "unacceptable"] * 100),
        aes(x = .data$Dose, y = .data$y),
        stat = "identity",
        position = "identity",
        width = min(diff(dose_grid)) / 2,
        colour = "red",
        fill = "red"
      ) +
      ylim(c(0, 100)) +
      ylab("Unacceptable probability [%]")

    # Combine it all together.
    plots_single <- list(plot1 = p1, plot2 = p2, plot3 = p3, plot_loss = p_loss)
    plot_joint <- gridExtra::arrangeGrob(p1, p2, p3, p_loss, nrow = 4)
  }

  list(plots_single = plots_single, plot_joint = plot_joint)
}

#' Building the Plot for `nextBest-NextBestTDsamples` Method.
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' Helper function which creates the plot for [`nextBest-NextBestTDsamples()`]
#' method.
#'
#' @param dose_target_drt_samples (`numeric`)\cr vector of in-trial samples.
#' @param dose_target_eot_samples (`numeric`)\cr vector of end-of-trial samples.
#' @param dose_target_drt (`number`)\cr target in-trial estimate.
#' @param dose_target_eot (`number`)\cr target end-of-trial estimate.
#' @param dose_grid_range (`numeric`)\cr range of dose grid.
#' @param nextBest (`NextBestTDsamples`)\cr the rule for the next best dose.
#' @param doselimit (`number`)\cr the maximum allowed next dose.
#' @param next_dose (`number`)\cr next best dose.
#'
#' @export
#'
h_next_best_tdsamples_plot <- function(dose_target_drt_samples,
                                       dose_target_eot_samples,
                                       dose_target_drt,
                                       dose_target_eot,
                                       dose_grid_range,
                                       nextBest,
                                       doselimit,
                                       next_dose) {
  assert_numeric(dose_target_drt_samples, any.missing = FALSE)
  assert_numeric(dose_target_eot_samples, any.missing = FALSE)
  assert_number(dose_target_drt)
  assert_number(dose_target_eot)
  assert_range(dose_grid_range, finite = TRUE, unique = FALSE)
  assert_class(nextBest, "NextBestTDsamples")
  assert_number(doselimit)
  assert_number(next_dose, na.ok = TRUE)

  lbl1 <- paste("TD", nextBest@prob_target_drt * 100, "Estimate")
  lbl2 <- paste("TD", nextBest@prob_target_eot * 100, "Estimate")
  labels <- data.frame(
    Type = c("during", "end", "Max", "Next"),
    Alpha = c(0.25, 0.25, 1, 1),
    x = c(
      dose_target_drt,
      dose_target_eot,
      min(doselimit, dose_grid_range[2]),
      next_dose
    )
  )
  p <- ggplot(
    data = rbind(
      data.frame(period = "during", TD = dose_target_drt_samples),
      data.frame(period = "end", TD = dose_target_eot_samples)
    ),
    aes(x = .data$TD, colour = .data$period),
  ) +
    geom_density(
      aes(fill = .data$period, colour = .data$period),
      alpha = 0.25,
      bounds = dose_grid_range,
      show.legend = FALSE
    ) +
    geom_vline(data = labels, aes(xintercept = x, colour = Type)) +
    ylab("Posterior density") +
    scale_colour_manual(
      name = NULL,
      values = c("during" = "orange", "end" = "violet", "Max" = "red", "Next" = "blue"),
      labels = c("during" = lbl1, "end" = lbl2, "Max" = "Max", "Next" = "Next")
    ) +
    scale_fill_manual(
      values = c("during" = "orange", "end" = "violet")
    )
}

#' Building the Plot for `nextBest-NextBestTD` Method.
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' Helper function which creates the plot for [`nextBest-NextBestTD()`] method.
#'
#' @param prob_target_drt (`proportion`)\cr target DLT probability during the trial.
#' @param dose_target_drt (`number`)\cr target dose estimate during the trial.
#' @param prob_target_eot (`proportion`)\cr target DLT probability at the end of the trial.
#' @param dose_target_eot (`number`)\cr target dose estimate at the end of the trial.
#' @param data (`Data`)\cr the data object from which the dose grid will be fetched.
#' @param prob_dlt (`numeric`)\cr DLT probabilities for doses in grid.
#' @param doselimit (`number`)\cr the maximum allowed next dose.
#' @param next_dose (`number`)\cr next best dose.
#'
#' @export
#'
h_next_best_td_plot <- function(prob_target_drt,
                                dose_target_drt,
                                prob_target_eot,
                                dose_target_eot,
                                data,
                                prob_dlt,
                                doselimit,
                                next_dose) {
  assert_probability(prob_target_drt)
  assert_number(dose_target_drt)
  assert_probability(prob_target_eot)
  assert_number(dose_target_eot)
  assert_class(data, "Data")
  assert_probabilities(prob_dlt, len = data@nGrid)
  assert_number(doselimit)
  assert_number(next_dose, na.ok = TRUE)

  dosegrid_range <- dose_grid_range(data)

  p <- ggplot(
    data = data.frame(x = data@doseGrid, y = prob_dlt),
    aes(x = .data$x, y = .data$y)
  ) +
    geom_line(colour = "red", linewidth = 1.5) +
    coord_cartesian(xlim = c(0, dosegrid_range[2])) +
    ylim(c(0, 1)) +
    xlab("Dose Levels") +
    ylab("Probability of DLT")
  if (h_in_range(dose_target_drt, range = dosegrid_range, bounds_closed = TRUE)) {
    p <- p +
      geom_point(
        data = data.frame(x = dose_target_drt, y = prob_target_drt),
        aes(x = .data$x, y = .data$y),
        colour = "orange",
        shape = 15,
        size = 8
      ) +
      annotate(
        geom = "text",
        label = paste("TD", prob_target_drt * 100, "Estimate"),
        x = dose_target_drt + 1,
        y = prob_target_drt - 0.2,
        size = 5,
        colour = "orange"
      )
  }

  if (h_in_range(dose_target_eot, range = dosegrid_range, bounds_closed = TRUE)) {
    p <- p +
      geom_point(
        data = data.frame(x = dose_target_eot, y = prob_target_eot),
        aes(x = .data$x, y = .data$y),
        colour = "violet",
        shape = 16,
        size = 8
      ) +
      annotate(
        geom = "text",
        label = paste("TD", prob_target_eot * 100, "Estimate"),
        x = dose_target_eot + 1,
        y = prob_target_eot - 0.1,
        size = 5,
        colour = "violet"
      )
  }

  maxdoselimit <- min(doselimit, dosegrid_range[2])

  p +
    geom_vline(xintercept = maxdoselimit, colour = "brown", lwd = 1.1) +
    geom_text(
      data = data.frame(x = maxdoselimit, y = 0),
      aes(x = .data$x, y = .data$y, label = "Max", hjust = +1, vjust = -30),
      angle = 90,
      vjust = 1.5,
      hjust = 0.5,
      colour = "brown",
    ) +
    geom_vline(xintercept = next_dose, colour = "purple", lwd = 1.1) +
    geom_text(
      data = data.frame(x = next_dose, y = 0),
      aes(x = .data$x, y = .data$y, label = "Next", hjust = 0, vjust = -30),
      angle = 90,
      vjust = -0.5,
      hjust = 0.5,
      colour = "purple"
    )
}

#' Building the Plot for `nextBest-NextBestMaxGain` Method.
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' Helper function which creates the plot for [`nextBest-NextBestMaxGain()`] method.
#'
#' @param prob_target_drt (`proportion`)\cr target DLT probability during the trial.
#' @param dose_target_drt (`number`)\cr target dose estimate during the trial.
#' @param prob_target_eot (`proportion`)\cr target DLT probability at the end of the trial.
#' @param dose_target_eot (`number`)\cr target dose estimate at the end of the trial.
#' @param dose_mg (`number`)\cr the dose corresponding to the maximum gain.
#' @param max_gain (`number`)\cr the maximum gain estimate.
#' @param next_dose (`number`)\cr next best dose.
#' @param doselimit (`number`)\cr the maximum allowed next dose.
#' @param data (`DataDual`)\cr the data object from which the dose grid will be fetched.
#' @param model (`ModelTox`)\cr the DLT model.
#' @param model_eff (`Effloglog`)\cr the efficacy model.
#'
#' @export
#'
h_next_best_mg_plot <- function(prob_target_drt,
                                dose_target_drt,
                                prob_target_eot,
                                dose_target_eot,
                                dose_mg,
                                max_gain,
                                next_dose,
                                doselimit,
                                data,
                                model,
                                model_eff) {
  assert_probability(prob_target_drt)
  assert_number(dose_target_drt)
  assert_probability(prob_target_eot)
  assert_number(dose_target_eot)
  assert_number(dose_mg, na.ok = TRUE)
  assert_number(max_gain, na.ok = TRUE)
  assert_number(next_dose, na.ok = TRUE)
  assert_number(doselimit)
  assert_class(data, "Data")
  assert_class(model, "ModelTox")
  assert_class(model_eff, "Effloglog")

  dosegrid_range <- dose_grid_range(data)

  data_plot <- data.frame(
    dose = rep(data@doseGrid, 3),
    y = c(
      prob(dose = data@doseGrid, model = model),
      efficacy(dose = data@doseGrid, model = model_eff),
      gain(dose = data@doseGrid, model_dle = model, model_eff = model_eff)
    ),
    group = c(
      rep("p(DLE)", data@nGrid),
      rep("Expected Efficacy", data@nGrid),
      rep("Gain", data@nGrid)
    )
  )

  p <- ggplot(data = data_plot, aes(x = .data$dose, y = .data$y)) +
    geom_line(aes(group = group, color = group), linewidth = 1.5) +
    ggplot2::scale_colour_manual(name = "curves", values = c("blue", "green3", "red")) +
    coord_cartesian(xlim = c(0, dosegrid_range[2])) +
    ylim(range(data_plot$y)) +
    xlab("Dose Level") +
    ylab("Values")

  if (h_in_range(dose_target_eot, range = dosegrid_range, bounds_closed = FALSE)) {
    lab <- paste("TD", prob_target_eot * 100, "Estimate")
    p <- p +
      geom_point(
        data = data.frame(x = dose_target_eot, y = prob_target_eot),
        aes(x = .data$x, y = .data$y),
        colour = "violet",
        shape = 16,
        size = 8
      ) +
      annotate(
        geom = "text", label = lab, x = dose_target_eot - 1, y = 0.2, size = 5, colour = "violet"
      )
  }

  if (h_in_range(dose_mg, range = dosegrid_range, bounds_closed = FALSE)) {
    p <- p +
      geom_point(
        data = data.frame(x = dose_mg, y = max_gain),
        aes(x = .data$x, y = .data$y),
        colour = "green3",
        shape = 17,
        size = 8
      ) +
      annotate(
        "text",
        label = "Max Gain Estimate", x = dose_mg, y = max_gain - 0.1, size = 5, colour = "green3"
      )
  }

  if (h_in_range(dose_target_drt, range = dosegrid_range, bounds_closed = FALSE)) {
    lab <- paste("TD", prob_target_drt * 100, "Estimate")
    p <- p +
      geom_point(
        data = data.frame(x = dose_target_drt, y = prob_target_drt),
        aes(x = .data$x, y = .data$y),
        colour = "orange",
        shape = 15,
        size = 8
      ) +
      annotate(
        geom = "text", label = lab, x = dose_target_drt + 25, y = prob_target_drt + 0.01, size = 5, colour = "orange"
      )
  }

  maxdoselimit <- min(doselimit, dosegrid_range[2])

  p +
    geom_vline(xintercept = maxdoselimit, colour = "brown", lwd = 1.1) +
    annotate(
      geom = "text",
      label = "Max",
      x = maxdoselimit - 2,
      y = max(data_plot$y),
      size = 5,
      angle = 90,
      vjust = -0.5,
      hjust = 0.5,
      colour = "brown"
    ) +
    geom_vline(xintercept = next_dose, colour = "purple", lwd = 1.1) +
    annotate(
      geom = "text",
      label = "Next",
      x = next_dose + 1,
      y = max(data_plot$y) - 0.05,
      size = 5,
      angle = 90,
      vjust = 1.5,
      hjust = 0.5,
      color = "purple"
    )
}

#' Building the Plot for `nextBest-NextBestMaxGainSamples` Method.
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' Helper function which creates the plot for [`nextBest-NextBestMaxGainSamples()`] method.
#'
#' @param prob_target_drt (`proportion`)\cr target DLT probability during the trial.
#' @param dose_target_drt (`number`)\cr target dose estimate during the trial.
#' @param prob_target_eot (`proportion`)\cr target DLT probability at the end of the trial.
#' @param dose_target_eot (`number`)\cr target dose estimate at the end of the trial.
#' @param dose_mg (`number`)\cr the dose corresponding to the maximum gain.
#' @param dose_mg_samples (`numeric`)\cr for every sample, the dose (from the dose grid)
#'   that gives the maximum gain value.
#' @param next_dose (`number`)\cr next best dose.
#' @param doselimit (`number`)\cr the maximum allowed next dose.
#' @param dose_grid_range (`numeric`)\cr dose grid range.
#'
#' @export
#'
h_next_best_mgsamples_plot <- function(prob_target_drt,
                                       dose_target_drt,
                                       prob_target_eot,
                                       dose_target_eot,
                                       dose_mg,
                                       dose_mg_samples,
                                       next_dose,
                                       doselimit,
                                       dose_grid_range) {
  assert_range(dose_grid_range, finite = TRUE, unique = FALSE)
  assert_probability(prob_target_drt)
  assert_number(dose_target_drt)
  assert_probability(prob_target_eot)
  assert_number(dose_target_eot)
  assert_number(dose_mg, na.ok = TRUE)
  assert_numeric(
    dose_mg_samples,
    lower = dose_grid_range[1], upper = dose_grid_range[2], finite = TRUE, any.missing = FALSE
  )
  assert_number(next_dose, na.ok = TRUE)
  assert_number(doselimit)

  p <- ggplot() +
    geom_histogram(
      data = data.frame(Gstar = dose_mg_samples),
      aes(x = .data$Gstar),
      fill = "darkgreen",
      colour = "green3",
      binwidth = 25
    ) +
    coord_cartesian(xlim = c(0, dose_grid_range[2])) +
    ylab("Posterior density")

  if (h_in_range(dose_target_drt, range = dose_grid_range, bounds_closed = FALSE)) {
    lab <- paste("TD", prob_target_drt * 100, "Estimate")
    p <- p +
      geom_vline(xintercept = dose_target_drt, colour = "orange", lwd = 1.1) +
      annotate(
        geom = "text", label = lab, x = dose_target_drt, y = 0, hjust = -0.1, vjust = -20, size = 5, colour = "orange"
      )
  }

  if (h_in_range(dose_target_eot, range = dose_grid_range, bounds_closed = FALSE)) {
    lab <- paste("TD", prob_target_eot * 100, "Estimate")
    p <- p +
      geom_vline(xintercept = dose_target_eot, colour = "violet", lwd = 1.1) +
      annotate(
        geom = "text", label = lab, x = dose_target_eot, y = 0, hjust = -0.1, vjust = -25, size = 5, colour = "violet"
      )
  }

  if (h_in_range(dose_mg, range = dose_grid_range, bounds_closed = FALSE)) {
    lab <- "Gstar Estimate"
    p <- p +
      geom_vline(xintercept = dose_mg, colour = "green", lwd = 1.1) +
      annotate(
        geom = "text", label = lab, x = dose_mg, y = 0, hjust = -0.1, vjust = -25, size = 5, colour = "green"
      )
  }

  maxdoselimit <- min(doselimit, dose_grid_range[2])

  p +
    geom_vline(xintercept = maxdoselimit, colour = "red", lwd = 1.1) +
    annotate(
      geom = "text", label = "Max", x = maxdoselimit, y = 0, hjust = +1, vjust = -35, colour = "red"
    ) +
    geom_vline(xintercept = next_dose, colour = "blue", lwd = 1.1) +
    annotate(
      geom = "text", label = "Next", x = next_dose, y = 0, hjust = 0.1, vjust = -30, colour = "blue"
    )
}

# tidy ----

## generic ----

#' Tidying `CrmPackClass` objects
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' In the spirit of the `broom` package, provide a method to convert a
#' `CrmPackClass` object to a (list of) tibbles.
#'
#' @param x (`CrmPackClass`)\cr the object to be tidied.
#' @param ... potentially used by class-specific methods
#'
#' @return A (list of) tibble(s) representing the object in tidy form.
#'
#' @export
#'
setGeneric(
  name = "tidy",
  def = function(x, ...) {
    standardGeneric("tidy")
  }
)

## CrmPackClass ----

#' Tidy a `CrmPackClass` Object
#'
#' Following the principles of the `broom` package, convert a `CrmPackClass`
#' object to a (list of) tibbles.  This is a basic, default representation.
#'
#' @param x (`CrmPackClass`)\cr the object to be tidied.
#' @param ... potentially used by class-specific methods.
#' @rdname tidy
#' @aliases tidy-CrmPackClass
#' @keywords methods
#' @example examples/CrmPackClass-method-tidy.R
#'
#' @export
setMethod(
  f = "tidy",
  signature = signature(x = "CrmPackClass"),
  definition = function(x, ...) {
    rv <- h_tidy_all_slots(x) %>% h_tidy_class(x)
    if (length(rv) == 1) {
      rv[[names(rv)[1]]] %>% h_tidy_class(x)
    } else {
      rv
    }
  }
)

#' @include McmcOptions-class.R
#' @include Samples-validity.R
#' @include CrmPackClass-class.R
NULL

# Samples ----

## class ----

#' `Samples`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`Samples`] is the class to store the MCMC samples.
#'
#' @slot data (`list`)\cr MCMC samples of the parameter. Each entry in this list
#'   must be a vector (in case of a scalar parameter) or matrix (in case of a
#'   vector-valued parameter) with samples.
#'   In case of matrix, every row is a separate sample, while columns correspond
#'   to the dimension of the parameter.
#' @slot options (`McmcOptions`)\cr MCMC options that were used to generate the
#'   samples.
#'
#' @aliases Samples
#' @export
#'
.Samples <- setClass(
  Class = "Samples",
  slots = c(
    data = "list",
    options = "McmcOptions"
  ),
  prototype = prototype(
    data = list(),
    options = McmcOptions()
  ),
  contains = "CrmPackClass",
  validity = v_samples
)

## constructor ----

#' @rdname Samples-class
#'
#' @param data see slot definition.
#' @param options see slot definition.
#'
#' @export
#' @example examples/Samples-class.R
#'
Samples <- function(data, options) {
  new("Samples", data = data, options = options)
}

## default constructor ----

#' @rdname Samples-class
#' @note Typically, end users will not use the `.DefaultSamples()` function.
#' @export
.DefaultSamples <- function() {
  mcmc(
    data = .DefaultData(),
    model = .DefaultLogisticLogNormal(),
    options = .DefaultMcmcOptions()
  )
}

#' @include helpers.R
#' @include McmcOptions-validity.R
#' @include CrmPackClass-class.R
NULL

# McmcOptions ----

## class ----

#' `McmcOptions`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`McmcOptions`] is a class for the three canonical MCMC options as well as
#' Random Number Generator settings.
#'
#' @slot iterations (`count`)\cr number of MCMC iterations.
#' @slot burnin (`count`)\cr number of burn-in iterations which are not saved.
#' @slot step (`count`)\cr only every `step`-th iteration is saved after
#'   the `burnin`. In other words, a sample from iteration
#'   `i = 1,...,iterations`, is saved if and only if
#'   `(i - burnin) mod step = 0`.\cr
#'   For example, for `iterations = 6`, `burnin = 0` and `step = 2`, only
#'   samples from iterations `2,4,6` will be saved.
#' @slot rng_kind (`string`)\cr a Random Number Generator (RNG) type used by
#'   [`rjags`]. It must be one out of the following four values:
#'   `base::Wichmann-Hill`, `base::Marsaglia-Multicarry`,
#'   `base::Super-Duper`, `base::Mersenne-Twister`, or `NA_character_`.
#'   If it is `NA_character_` (default), then the RNG kind will be chosen by
#'   [`rjags`].
#' @slot rng_seed (`number`)\cr a Random Number Generator (RNG) seed
#'   used by [`rjags`] for a chosen `rng_kind`. It must be an integer scalar or
#'   `NA_integer_`, which means that the seed will be chosen by [`rjags`].
#'
#' @aliases McmcOptions
#' @export
#'
.McmcOptions <- setClass(
  Class = "McmcOptions",
  slots = c(
    iterations = "integer",
    burnin = "integer",
    step = "integer",
    rng_kind = "character",
    rng_seed = "integer"
  ),
  prototype = prototype(
    iterations = 1000L,
    burnin = 100L,
    step = 2L,
    rng_kind = NA_character_,
    rng_seed = NA_integer_
  ),
  contains = "CrmPackClass",
  validity = v_mcmc_options
)

## constructor ----

#' @rdname McmcOptions-class
#'
#' @param burnin (`count`)\cr number of burn-in iterations which are not saved.
#' @param step (`count`)\cr only every step-th iteration is saved after
#'   the burn-in.
#' @param samples (`count`)\cr number of resulting samples.
#' @param rng_kind (`string`)\cr the name of the RNG type. Possible types are:
#'   `Wichmann-Hill`, `Marsaglia-Multicarry`, `Super-Duper`, `Mersenne-Twister`.
#'   If it is `NA` (default), then the RNG kind will be chosen by `[rjags`].
#' @param rng_seed (`number`)\cr RNG seed corresponding to chosen `rng_kind`.
#'   It must be an integer value or `NA` (default), which means that the seed
#'   will be chosen by `[rjags`].
#'
#' @export
#' @example examples/McmcOptions-class-McmcOptions.R
#'
McmcOptions <- function(burnin = 1e4L,
                        step = 2L,
                        samples = 1e4L,
                        rng_kind = NA_character_,
                        rng_seed = NA_integer_) {
  assert_count(burnin, positive = TRUE)
  assert_count(step, positive = TRUE)
  assert_count(samples, positive = TRUE)
  assert_string(rng_kind, na.ok = TRUE)
  assert_count(rng_seed, na.ok = TRUE)

  if (!is.na(rng_kind)) {
    rng_kind <- paste0("base::", rng_kind)
  } else {
    rng_kind <- NA_character_
  }
  if (!is.na(rng_seed)) {
    rng_seed <- as.integer(rng_seed)
  } else {
    rng_seed <- NA_integer_
  }

  .McmcOptions(
    iterations = as.integer(burnin + (step * samples)),
    burnin = as.integer(burnin),
    step = as.integer(step),
    rng_kind = rng_kind,
    rng_seed = as.integer(rng_seed)
  )
}

## default constructor ----

#' @rdname McmcOptions-class
#' @note Typically, end users will not use the `.DefaultMcmcOptions()` function.
#' @export
.DefaultMcmcOptions <- function() {
  McmcOptions(
    burnin = 250,
    samples = 1000
  )
}

#' @include helpers.R
#' @include ModelParams-validity.R
#' @include CrmPackClass-class.R
NULL

# ModelParamsNormal ----

## class ----

#' `ModelParamsNormal`
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' [`ModelParamsNormal`] is the class for a bivariate normal model parameters,
#' i.e. the mean vector, covariance matrix and precision matrix.
#' The precision matrix is an inverse of the covariance matrix in the
#' `JAGS` and it is computed internally by the object constructor function.
#'
#' @slot mean (`numeric`)\cr the mean vector.
#' @slot cov (`matrix`)\cr the covariance matrix.
#' @slot prec (`matrix`)\cr the precision matrix, which is an inverse matrix of the `cov`.
#'
#' @seealso [`ModelLogNormal`], [`LogisticNormalMixture`].
#'
#' @aliases ModelParamsNormal
#' @export
#'
.ModelParamsNormal <- setClass(
  Class = "ModelParamsNormal",
  slots = c(
    mean = "numeric",
    cov = "matrix",
    prec = "matrix"
  ),
  contains = "CrmPackClass",
  validity = v_model_params_normal
)

## constructor ----

#' @rdname ModelParamsNormal-class
#'
#' @param mean (`numeric`)\cr the prior mean vector.
#' @param cov (`matrix`)\cr the prior covariance matrix. The precision matrix
#'   `prec` is internally calculated as an inverse of `cov`.
#'
#' @export
#' @examples
#' ModelParamsNormal(mean = c(1, 6), cov = diag(2))
ModelParamsNormal <- function(mean, cov) {
  assert_matrix(
    cov,
    mode = "numeric",
    any.missing = FALSE,
    nrows = length(mean),
    ncols = length(mean)
  )
  # To ensure that `cov` is invertible:
  assert_true(h_is_positive_definite(cov, length(mean)))

  .ModelParamsNormal(
    mean = mean,
    cov = cov,
    prec = solve(cov)
  )
}

## default constructor ----

#' @rdname ModelParamsNormal-class
#' @note Typically, end users will not use the `.ModelPAramsNormal()` function.
#' @export
.DefaultModelParamsNormal <- function() {
  ModelParamsNormal(
    mean = c(1, 0),
    cov = matrix(c(1, 0, 0, 1), nrow = 2)
  )
}

#' @include McmcOptions-methods.R
NULL

# v_samples ----

#' Internal Helper Functions for Validation of [`Samples`] Objects
#'
#' @description These functions are only used internally to validate the format
#'   of an input [`Samples`] or inherited classes and therefore not exported.
#'
#' @name v_samples_objects
#' @param object (`Samples`)\cr object to validate.
#' @return A `character` vector with the validation failure messages, or `TRUE`
#'   in case validation passes.
NULL

#' @describeIn v_samples_objects validates that the [`Samples`] object contains
#'   valid `data` slot.
v_samples <- function(object) {
  v <- Validate()
  v$check(
    all(sapply(object@data, NROW) == size(object@options)),
    "Every element in data must be of the same length (no. of rows) as the sample size was"
  )
  v$check(
    all(sapply(object@data, test_numeric, finite = TRUE, any.missing = FALSE)),
    "Every element in data must be a finite object of type integer or double"
  )
  v$result()
}

#' Apply a Function to Subsets of Data Frame.
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' `dapply` splits the data `df` into the subsets defined by `f`,
#' and applies function `FUN` to each of the subset.
#' All the results are row-binded and returned as `data.frame` object.
#'
#' @param df (`data frame`)\cr data set to be divided into groups.
#' @param f (`factor` or `formula` or `list`)\cr a factor in the sense that
#'   `as.factor(f)` defines the grouping, or a `list` of such factors in which
#'   case their interaction is used for the grouping. `f` can also be a formula
#'   of the form `~ g1 + ... + gk` to split by the interaction of the variables
#'   `g1, ..., gk`. This parameter is passed directly into [split()] function.
#' @param FUN (`function`)\cr the function to be applied to each subset of `df`
#'   defined by `f`.
#' @param ... parameters passed to [lapply()], which is used when applying a
#'   function `FUN` over groups defined by `f`.
#'
#' @return The [`data.frame`] object with results from `FUN`.
#'
#' @export
#' @example examples/utils-dapply.R
#'
dapply <- function(df, f, FUN, ...) {
  assert_data_frame(df)

  list_df <- split(df, f = f)
  list_df <- lapply(list_df, FUN, ...)
  df2 <- do.call(rbind, list_df)
  rownames(df2) <- NULL
  df2
}

#' Convenience function to make barplots of percentages
#'
#' @param x vector of samples
#' @param description xlab string
#' @param xaxisround rounding for xaxis labels (default: 0, i.e. integers will
#' be used)
#'
#' @return the ggplot2 object
#'
#' @keywords internal
#' @importFrom ggplot2 ggplot geom_histogram aes xlab ylab xlim
h_barplot_percentages <- function(x, description, xaxisround = 0) {
  assert_number(xaxisround, lower = 0)
  assert_character(description, len = 1, any.missing = FALSE)
  assert_numeric(x)

  tabx <- table(x) / length(x)
  dat <- data.frame(x = as.numeric(names(tabx)), perc = as.numeric(tabx) * 100)
  ggplot() +
    geom_bar(aes(x = x, y = perc),
      data = dat,
      stat = "identity",
      position = "identity",
      width = ifelse(nrow(dat) > 1, min(diff(dat$x)) / 2, 1)
    ) +
    xlab(description) +
    ylab("Percent") +
    scale_x_continuous(
      breaks =
        round(dat$x, xaxisround)
    )
}



#' Helper function to calculate percentage of true stopping rules for
#' report label output
#' calculates true column means and converts output into percentages
#' before combining the output with the report label; output is passed
#' to [`show()`] and output with cat to console
#'
#' @param stop_report object from summary method
#' @return named list with label and percentage of rule activation


h_calc_report_label_percentage <- function(stop_report) {
  stop_pct <- colMeans(stop_report) * 100
  stop_pct_to_print <- stop_pct[!is.na(names(stop_pct))]
  return(stop_pct_to_print)
}



#' Helper function to calculate average across iterations for each additional
#' reporting parameter
#' extracts parameter names as specified by user and averaged the values
#' for each specified parameter to [`show()`] and output with cat to console
#'
#' @param stats_list object from simulation with nested parameter values
#' (sublist for each parameter)
#' @return list of parameter names and averaged values for console output


h_summarize_add_stats <- function(stats_list) {
  # Extract the parameter names
  param_names <- names(stats_list[[1]])

  # Calculate the average for each parameter
  averages <- lapply(param_names, function(param) {
    values <- sapply(stats_list, function(x) x[[param]])
    mean(values)
  })

  return(list(param_names, averages))
}

#' Convert a Samples Object from an ordinal Model to the Equivalent Samples Object
#' from a Binary Model
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' A simple helper function that converts a [`Samples`] object from the fit of an
#' ordinal CRM model to that which would have been obtained from fitting a binary
#' CRM model for toxicities of a specified grade to the same observed data.
#'
#' @param obj (`Samples`)\cr the `Samples` object to covert
#' @param grade (`integer`)\cr the toxicity grade for which the equivalent data
#' is required.
#' @return A [`Samples`] object.
#'
#' @export
h_convert_ordinal_samples <- function(obj, grade) {
  # Validate
  assert_integer(grade, len = 1, lower = 1)
  assert_class(obj, "Samples")
  assert_subset(c(paste0("alpha", 1:grade), "beta"), names(obj@data))
  # Execute
  d <- list("alpha0" = obj@data[[paste0("alpha", grade)]], "alpha1" = obj@data$beta)
  Samples(data = d, options = obj@options)
}

#' @include McmcOptions-class.R
NULL

# size ----

## generic ----

#' Size of an Object
#'
#' @description `r lifecycle::badge("stable")`
#'
#' A method that computes the size of a given object. This can be for instance
#' a size of a MCMC sample, or the size of a cohort. See the help of a specific
#' method for more details.
#'
#' @param object (`McmcOptions` or `Samples` or `CohortSize`)\cr an object
#'   for which the size is computed.
#' @param ... further arguments passed to `size` specific methods.
#'
#' @return A size of a given object.
#' @export
#'
setGeneric(
  name = "size",
  def = function(object, ...) {
    standardGeneric("size")
  },
  valueClass = "integer"
)

## McmcOptions ----

#' @describeIn size compute the number of MCMC samples based on `McmcOptions`
#'   object.
#' @aliases size-McmcOptions
#' @example examples/McmcOptions-methods-size.R
setMethod(
  f = "size",
  signature = signature(object = "McmcOptions"),
  definition = function(object, ...) {
    iterations_relative <- object@iterations - object@burnin
    if (iterations_relative <= 0) {
      return(0L)
    }
    as.integer(floor(iterations_relative / object@step))
  }
)

# saveSample ----

## generic ----

#' Determining if this Sample Should be Saved
#'
#' @description `r lifecycle::badge("stable")`
#'
#' A method that determines if a sample from a given `iteration` should be
#' saved. The sample should be saved if and only if:
#' it is not in burn-in period and it matches the `step`.
#'
#' @param object (`McmcOptions`)\cr object based on which the answer is
#'   determined.
#' @param iteration (`count`)\cr the current iteration index.
#' @param ... not used.
#' @return `TRUE` if this sample should be saved.
#' @export
#'
setGeneric(
  name = "saveSample",
  def = function(object, iteration, ...) {
    standardGeneric("saveSample")
  },
  valueClass = "logical"
)

## McmcOptions ----

#' @describeIn saveSample determine if a sample should be saved.
#' @aliases saveSample-McmcOptions
#' @example examples/McmcOptions-methods-saveSample.R
setMethod(
  f = "saveSample",
  signature = signature(object = "McmcOptions"),
  definition = function(object, iteration, ...) {
    iteration_relative <- iteration - object@burnin
    iteration_relative > 0 && ((iteration_relative %% object@step) == 0)
  }
)

# v_mcmc_options ----

#' Internal Helper Functions for Validation of [`McmcOptions`] Objects
#'
#' @description `r lifecycle::badge("stable")`
#'
#' These functions are only used internally to validate the format of an input
#' [`McmcOptions`] or inherited classes and therefore not exported.
#'
#' @name v_mcmcoptions_objects
#' @param object (`McmcOptions`)\cr object to validate.
#' @return A `character` vector with the validation failure messages,
#'   or `TRUE` in case validation passes.
NULL

#' @describeIn v_mcmcoptions_objects validates that the [`McmcOptions`]
#'   object contains valid integer scalars `iterations`, `burnin` and `step`
#'   as well as proper parameters for Random Number Generator.
v_mcmc_options <- function(object) {
  v <- Validate()
  allowed_rng_kinds <- c(
    "base::Wichmann-Hill",
    "base::Marsaglia-Multicarry",
    "base::Super-Duper",
    "base::Mersenne-Twister",
    NA_character_
  )

  v$check(
    test_int(object@iterations, lower = 1L),
    "iterations must be integer scalar greater than or equal to 1"
  )
  v$check(
    test_int(object@burnin, lower = 0L),
    "burn-in must be non-negative integer scalar"
  )
  # This below check should not be conducted in above test, using
  # `upper = object@iterations -1` argument, since object@iterations might be
  # not-valid. In such a case `test_int` throws an internal error.
  v$check(
    test_true(object@burnin < object@iterations),
    "burn-in must be lower than iterations"
  )
  v$check(
    test_int(object@step, lower = 1L),
    "step must be integer scalar greater than or equal to 1"
  )

  is_rng_kind_scalar <- test_string(object@rng_kind, na.ok = TRUE)
  v$check(is_rng_kind_scalar, "rng_kind must be a single string")
  v$check(
    test_subset(object@rng_kind, allowed_rng_kinds),
    paste0(
      "rng_kind must one of the following: ",
      paste(allowed_rng_kinds, collapse = ", "),
      ". User specifies the rng_kind without `base::` prefix"
    )
  )

  is_rng_seed_scalar <- test_int(object@rng_seed, na.ok = TRUE)
  v$check(is_rng_seed_scalar, "rng_seed must be an integer scalar")

  # Below `if` condition is not only reasonable but also needed as R CMD check
  # is activating some stricter checks and it fails when arguments to `||` are
  # not scalars, even if `||` works well with vectors of length > 1.
  if (is_rng_kind_scalar && is_rng_seed_scalar) {
    v$check(
      !is.na(object@rng_kind) || is.na(object@rng_seed),
      "rng_seed supplied but rng_kind not set"
    )
  }
  v$result()
}

#' Internal Helper Functions for Validation of Model Parameters Objects
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' These functions are only used internally to validate the format of an object
#' with model parameters or inherited classes and therefore not exported.
#'
#' @name v_model_params
#' @return A `character` vector with the validation failure messages,
#'   or `TRUE` in case validation passes.
NULL

#' @describeIn v_model_params a helper function that validates multivariate normal
#'   parameters.
#' @param object (`ModelParamsNormal`)\cr multivariate normal parameters object
#'   to validate.
v_model_params_normal <- function(object) {
  v <- Validate()

  v$check(
    test_numeric(x = object@mean, min.len = 2L, any.missing = FALSE),
    "mean must have length of at least 2 and no missing values are allowed"
  )
  is_cov_valid <- h_is_positive_definite(object@cov, length(object@mean))
  v$check(
    is_cov_valid,
    "cov must be positive-definite matrix without any missing values"
  )
  is_prec_valid <- h_is_positive_definite(object@prec, length(object@mean))
  v$check(
    is_prec_valid,
    "prec must be positive-definite matrix without any missing values"
  )
  if (is_cov_valid && is_prec_valid) {
    v$check(
      all.equal(object@cov %*% object@prec, diag(1, length(object@mean)), check.attributes = FALSE) == TRUE,
      "prec must be inverse of cov"
    )
  }
  v$result()
}

# nolint start

#####################################################################################
## Author: Daniel Sabanes Bove [sabanesd *a*t* roche *.* com]
## Project: Object-oriented implementation of CRM designs
##
## Time-stamp: <[crmPack-package.R] by DSB Mon 11/05/2015 17:47>
##
## Description:
## Package description.
##
## History:
## 29/01/2014   file creation
#####################################################################################

#' Object-oriented implementation of CRM designs
#'
#' @name crmPack-package
#' @aliases crmPack
#' @docType package
#' @title Object-oriented implementation of CRM designs
#' @author Daniel Sabanes Bove \email{daniel.sabanesbove@@gmx.net}, W
#' Wai Yin Yeung \email{winnie.yeung@@roche.com}
#' Giuseppe Palermo \email{giuseppe.palermo@@roche.com},
#' Thomas Jaki \email{jaki.thomas@@gmail.com}
# @useDynLib crmPack
#  cpp_glmBayesMfp cpp_bfgs cpp_optimize cpp_sampleGlm cpp_evalZdensity
#  cpp_coxfit
#' @import checkmate
#' @import ggplot2
#' @import methods
#' @import tibble
#' @importFrom grid grid.draw
#' @importFrom gridExtra arrangeGrob
#' @importFrom graphics plot hist legend lines matlines matplot
#' @importFrom stats binomial coef cov2cor gaussian glm lm median model.matrix
#'   optim pgamma plogis pnorm qgamma qlogis qnorm quantile rbinom rgamma
#'   approxfun rnorm runif uniroot var vcov step mad pbeta dbeta dgamma
#'   setNames
#' @importFrom utils data head tail capture.output
#' @importFrom lifecycle badge
#' @importFrom rjags jags.model jags.samples
#' @importFrom futile.logger flog.threshold flog.logger flog.trace TRACE FATAL
#' @importFrom kableExtra kbl add_header_above column_spec collapse_rows
#'   kable_styling add_footnote kable
#'
#' @keywords package
#' @references Sabanes Bove D, Yeung WY, Palermo G, Jaki T (2019).
#' "Model-Based Dose Escalation Designs in R with crmPack."
#' Journal of Statistical Software, 89(10), 1-22.
#' doi:10.18637/jss.v089.i10 (URL: http://doi.org/10.18637/jss.v089.i10).
{}

##' @keywords internal
.onAttach <- function(libname, pkgname) {
  packageStartupMessage(
    "Type crmPackHelp() to open help browser\n",
    "Type crmPackExample() to open example\n"
  )
}

## need to declare global variable / function
## names in order to avoid R CMD check notes:
globalVariables(c(
  "log.betaZ",
  "precW",
  "pow",
  "nObs",
  "betaZ",
  "x",
  "betaW",
  "xLevel",
  "precW",
  "z",
  "nGrid",
  "doseGrid",
  "betaWintercept",
  "delta",
  "deltaStart",
  "delta2",
  "Effsamples",
  "logit<-",
  "rho0",
  "alpha0",
  "delta0",
  "alpha1",
  "delta1",
  "inverse",
  "priorCov",
  "theta",
  "comp0",
  "w",
  "DLTs",
  "y",
  "group",
  "annotate",
  "probSamples",
  "prec",
  "nu",
  "samples",
  "Type",
  "patient",
  "toxicity",
  "ID",
  "biomarker",
  "traj",
  "Statistic",
  "perc",
  "..density..",
  "middle",
  "lower",
  "upper",
  "middleBiomarker",
  "lowerBiomarker",
  "upperBiomarker",
  "nObsshare",
  "xshare",
  "yshare",
  "thisProb.PL",
  "thisMeanEff.PL",
  "thisSize.PL",
  "probit<-",
  "refDose",
  "Tmax",
  "u",
  "eps",
  "h",
  "lambda",
  "cadj",
  "A",
  "lambda_p",
  "cond",
  "t0",
  "tend",
  "t0_case",
  "tend_case",
  "yhat",
  "ref_dose",
  "comp",
  "X",
  "skel_probs",
  "is_combo",
  "results",
  "k",
  "value",
  "Parameter"
))

# nolint end

1		#' Convert Object's Attributes to a Tibble
2		#'
3		#' @description `r lifecycle::badge("experimental")`
4		#'
5		#' A helper function that interrogates an object to see if it has attributes
6		#' and, if so, converts them to a (list of) tibbles. Columns are named after
7		#' attributes. If attributes have different lengths but recycling is possible,
8		#' a single `tibble` is returned. Otherwise, a `list` of tibbles is returned.
9		#'
10		#' @param x (`CrmPackObject`)\cr object whose attributes will be interrogated.
11		#' @param .ignore (`character`)\cr names of attrributes to be ignored.
12		#'
13		#' @return A [`tibble`] or `list` of [`tibble`]s containg the values of the
14		#' object's attributes.
15		#'
16		#' @keywords internal
17		#' @noRd
18		h_handle_attributes <- function(x, .ignore = c("names", "class", "description", "row.names")) {
19	3x	a <- attributes(x)
20	3x	valid_names <- setdiff(names(a), .ignore)
21	3x	lapply(
22	3x	valid_names,
23	3x	function(n) {
24	18x	z <- attr(x, n)
25	18x	rv <- NULL
26		# Some Design classes have attributes that are functions or CrmPackClass objects
27	18x	if (!is.function(z)) {
28	18x	if (length(z) == 1) {
29	18x	if (is(z, "CrmPackClass")) {
30	!	z <- z %>% tidy()
31		}
32	18x	rv <- tibble::tibble(X = z)
33		} else {
34	!	if (length(z) == 0) {
35	!	rv <- tibble::tibble(X = NA)
36		} else {
37	!	if (is(z, "CrmPackClass")) {
38	!	rv <- z %>% tidy()
39		} else {
40	!	rv <- tibble::tibble(X = list(z))
41		}
42		}
43		}
44	18x	names(rv) <- n
45		}
46	18x	rv
47		}
48		) %>%
49	3x	dplyr::bind_cols()
50		}
51
52		#' Tidy a Single Slot of a CrmPackObject
53		#'
54		#' @description `r lifecycle::badge("experimental")`
55		#'
56		#' A helper function that converts a single slot of a `CrmPackObject` to a tibble.
57		#' If the slots value is a `list`, each element of the list is tidied individually.
58		#'
59		#' @param obj (`CrmPackObject`)\cr object to be converted.
60		#' @param slot_name (`character`)\cr name of the slot to be tidied.
61		#' @param col (`character`)\cr The name of the corresponding column in the tidied
62		#' tibble. Defaults to `slot_name`.
63		#' @param attributes (`flag`)\cr shoud the object's attributes, if any, be added
64		#' to the output tibble
65		#'
66		#' @return A [`tibble`]
67		#'
68		#' @keywords internal
69		#' @importFrom rlang :=
70		#' @noRd
71		h_tidy_slot <- function(obj, slot_name, col = NULL, attributes = FALSE) {
72	2415x	if (is.list(slot(obj, slot_name))) {
73	57x	return(
74	57x	lapply(
75	57x	slot(obj, slot_name),
76	57x	function(x) {
77	116x	if (is.data.frame(x)) {
78	6x	return(x)
79	110x	} else if (is.list(x) && stringr::str_detect(class(x)[1], stringr::fixed("tbl_"))) {
80		# Already tidied to a list.
81	!	return(x)
82	110x	} else if (is.numeric(x) \| is.character(x)) {
83		# tidy.numeric & tidy.character are deprecated
84	12x	return(tibble::tibble(!!{{ slot_name }} := x))
85		} else {
86	98x	return(x %>% tidy())
87		}
88		}
89		)
90		)
91		}
92	2358x	if (is(slot(obj, slot_name), "CrmPackClass")) {
93	260x	rv <- slot(obj, slot_name) %>%
94	260x	tidy()
95		} else {
96	2098x	if (is.null(col)) {
97	2098x	col <- slot_name
98		}
99	2098x	rv <- tibble::tibble({{ col }} := slot(obj, slot_name))
100		}
101	2358x	if (attributes) {
102	!	a <- h_handle_attributes(slot(obj, slot_name))
103	!	if (nrow(a) > 0) {
104	!	rv <- rv %>% dplyr::bind_cols(a)
105		}
106		}
107	2358x	rv
108		}
109
110		#' Tidy All Slots of a CrmPackObject
111		#'
112		#' @description `r lifecycle::badge("experimental")`
113		#'
114		#' A helper function that converts all the slots of a `CrmPackObject` to a
115		#' (list of) tibble(s).
116		#'
117		#' @param obj (`CrmPackObject`)\cr object to be tidied.
118		#' @param ... passed to h_tidy_slot
119		#'
120		#' @return A (list of) [`tibble`](s)
121		#'
122		#' @keywords internal
123		#' @noRd
124		h_tidy_all_slots <- function(obj, ...) {
125	574x	slot_names <- slotNames(obj)
126	574x	rv <- list()
127	574x	for (nm in slot_names) {
128	2610x	if (!is.function(slot(obj, nm))) {
129	2350x	rv[[nm]] <- h_tidy_slot(obj, nm, ...)
130		}
131		}
132		# Column bind of all list elements have the same number of rows
133	574x	if (length(rv) > 1 && length(unique(sapply(rv, nrow))) == 1) {
134	240x	rv <- rv %>% dplyr::bind_cols() # nolint
135		}
136	574x	rv
137		}
138
139		#' Amend the Class of a Tibble to Indicate that it Contains a Tidied `CrmPackObject`
140		#'
141		#' @description `r lifecycle::badge("experimental")`
142		#'
143		#' A helper function that prepends `tbl_<cls>`, where `<cls>` is the first
144		#' element of the class attribute of the original `CrmPackObject` to the class
145		#' attribute of a tibble
146		#'
147		#' @param d (`tibble`)\cr the tibble containing the tidied version of `obj`.
148		#' @param obj (`CrmPackObject`)\cr object to be converted.
149		#'
150		#' @return `d`, with an amended class attribute
151		#'
152		#' @keywords internal
153		#' @noRd
154		h_tidy_class <- function(d, obj) {
155	683x	cls <- class(obj)
156	683x	class(d) <- c(paste0("tbl_", cls[1]), class(d))
157	683x	d
158		}
159
160		#' Convert a `CrmPackObject`'s "Interval list" to a Min-Max
161		#'
162		#' @description `r lifecycle::badge("experimental")`
163		#'
164		#' `CrmPackClass` objects that define a set of intervals (such as `CohortSizeRange`)
165		#' typically contain a left-open vector that dfines the intervals. For example,
166		#' `my_size <- CohortSizeRange(intervals = c(0, 20), cohort_size = c(1, 3))` defines
167		#' two dose ranges: [0, 20) and [20, Inf). This is convenient for coding, but
168		#' awkward for reporting. This helper function converts this single-column
169		#' representation to a two-column representation that explicitly defines the
170		#' lower and upper ends of each interval. Using the example above, the converted
171		#' tibble would look like this:
172		#'
173		#' \| cohort_size \| min \| max \|
174		#' \| ----------: \| ---: \| ---: \|
175		#' \| 1 \| -Inf \| 20 \|
176		#' \| 3 \| 20 \| Inf \|
177		#'
178		#' @param x (`tibble`)\cr the tibble to be converted.
179		#' @param col (`tidy-eval`)\cr column containing the intervals.
180		#' @param min_col (`character`)\cr name of the column containing the lower end
181		#' of the interval in the returned value.
182		#' @param max_col (`character`)\cr name of the column containing the upper end
183		#' of the interval in the returned value.
184		#' @param range_min (`numeric`)\cr value of the lower end of the first interval.
185		#' @param range_max (`numeric`)\cr value of the upper end of the last interval.
186		#'
187		#' @return A `tibble` in min-max format, with one row more than the input tibble.
188		#'
189		#' @importFrom rlang :=
190		#' @keywords internal
191		#' @noRd
192		h_range_to_minmax <- function(
193		x,
194		col,
195		min_col = "min",
196		max_col = "max",
197		range_min = -Inf,
198		range_max = Inf) {
199	110x	vals <- x %>% dplyr::pull({{ col }})
200	110x	tibble(
201	110x	{{ min_col }} := c(range_min, vals),
202	110x	{{ max_col }} := c(vals, range_max)
203		)
204		}

1		#' Helpers for stripping expressions of `covr`-inserted trace code
2		#'
3		#' Workarounds to allow the package to continue to work while running `covr`
4		#' with minimal changes to the package code.
5		#'
6		#' @details
7		#' When using `covr`, the source code for package objects are modified to add
8		#' callbacks for each expression to log its execution. Given an arbitrary
9		#' expression, such as:
10		#'
11		#' expr
12		#'
13		#' The code will be modified before executing any package code to look like:
14		#'
15		#' if (TRUE) {
16		#' covr:::count("file.R:1:2:3:4:5:6:7:8")
17		#' expr
18		#' }
19		#'
20		#' These functions are used for stripping expressions of this code so that the
21		#' package continues to work as intended while running tests as part of running
22		#' `covr` to calculate package coverage.
23		#'
24		#' This method is non-exhaustive, covering only a subset of `covr`'s tracing
25		#' behaviors necessary for this package.
26		#'
27		#' @param expr (`language`)\cr an R expression or call to test or strip of
28		#' `covr` trace counters.
29		#'
30		#' @return A logical value or transformed expression with calls to
31		#' `covr:::count` removed.
32		#'
33		#' @name h_covr_helpers
34		#' @keywords internal
35		#'
36		NULL
37
38		#' @describeIn h_covr_helpers
39		#' Determine whether `covr` is currently running
40		h_covr_active <- function() {
41	90089x	identical(Sys.getenv("R_COVR"), "true")
42		}
43
44		#' @describeIn h_covr_helpers
45		#' Remove `covr` traces from an expression
46		h_covr_detrace <- function(expr) {
47	88741x	if (!h_covr_active()) {
48	2x	return(expr)
49		}
50
51	88739x	if (is.function(expr)) {
52	9x	body(expr) <- h_covr_detrace(body(expr))
53	9x	return(expr)
54		}
55
56	88730x	detrace <- function(x) {
57		# returns "missing" expression to avoid errors with calls
58	88730x	if (identical(x, bquote())) {
59	404x	return(x)
60		}
61
62	88326x	x <- h_covr_detrace_call(x)
63	43720x	if (is.call(x)) x[-1] <- lapply(x[-1], h_covr_detrace)
64	88326x	x
65		}
66
67	88730x	detrace(expr)
68		}
69
70		#' @describeIn h_covr_helpers
71		#' Determine whether the current expression is a `covr`-modified expression
72		h_is_covr_trace <- function(expr) {
73		# Matches `if (TRUE) { covr:::count(<trace>); <expr> }` (see covr:::trace_calls).
74	88331x	is.call(expr) &&
75	88331x	expr[[1]] == "if" &&
76	88331x	expr[[2]] == quote(TRUE) &&
77	88331x	expr[[3]][[1]] == "{" &&
78	88331x	length(expr[[3]] >= 3) &&
79	88331x	is.call(expr[[3]][[2]]) &&
80	88331x	expr[[3]][[2]][[1]] == call(":::", as.symbol("covr"), as.symbol("count"))
81		}
82
83		#' @describeIn h_covr_helpers
84		#' Extract the original expression from a `covr`-modified expression
85		h_covr_detrace_call <- function(expr) {
86	5318x	if (h_is_covr_trace(expr)) expr[[3]][[3]] else expr
87		}

1		#' @include helpers.R
2		#' @include Data-validity.R
3		#' @include CrmPackClass-class.R
4		NULL
5
6		# GeneralData-class ----
7
8		#' `GeneralData`
9		#'
10		#' @description `r lifecycle::badge("stable")`
11		#'
12		#' [`GeneralData`] is a class for general data input.
13		#'
14		#' @slot ID (`integer`)\cr unique patient IDs.
15		#' @slot cohort (`integer`)\cr the cohort (non-negative sorted) indices.
16		#' @slot nObs (`integer`)\cr number of observations, a single value.
17		#'
18		#' @aliases GeneralData
19		#' @export
20		#'
21		.GeneralData <- setClass(
22		Class = "GeneralData",
23		slots = c(
24		ID = "integer",
25		cohort = "integer",
26		nObs = "integer"
27		),
28		prototype = prototype(
29		ID = integer(),
30		cohort = integer(),
31		nObs = 0L
32		),
33		contains = "CrmPackClass",
34		validity = v_general_data
35		)
36
37		## default constructor ----
38
39		#' @rdname GeneralData-class
40		#' @note Typically, end users will not use the `.DefaultDataGeneral()` function.
41		#' @export
42		.DefaultDataGeneral <- function() {
43	!	stop(paste0("Class DataGeneral cannot be instantiated directly. Please use one of its subclasses instead."))
44		}
45
46		# Data ----
47
48		## class ----
49
50		#' `Data`
51		#'
52		#' @description `r lifecycle::badge("stable")`
53		#'
54		#' [`Data`] is a class for the data input.
55		#' It inherits from [`GeneralData`].
56		#'
57		#' @slot x (`numeric`)\cr the doses for the patients.
58		#' @slot y (`integer`)\cr the vector of toxicity events (0 or 1 integers).
59		#' @slot doseGrid (`numeric`)\cr the vector of all possible doses (sorted),
60		#' i.e. the dose grid.
61		#' @slot nGrid (`integer`)\cr number of gridpoints.
62		#' @slot xLevel (`integer`)\cr the levels for the doses the patients have been given,
63		#' w.r.t `doseGrid`.
64		#' @slot placebo (`logical`)\cr if `TRUE` the first dose level
65		#' in the `doseGrid`is considered as PLACEBO.
66		#'
67		#' @aliases Data
68		#' @export
69		#'
70		.Data <- setClass(
71		Class = "Data",
72		contains = "GeneralData",
73		slots = c(
74		x = "numeric",
75		y = "integer",
76		doseGrid = "numeric",
77		nGrid = "integer",
78		xLevel = "integer",
79		placebo = "logical"
80		),
81		prototype = prototype(
82		x = numeric(),
83		y = integer(),
84		doseGrid = numeric(),
85		nGrid = 0L,
86		xLevel = integer(),
87		placebo = FALSE
88		),
89		validity = v_data
90		)
91
92		## constructor ----
93
94		#' @rdname Data-class
95		#'
96		#' @details The `cohort` can be missing if and only if `placebo` is equal to
97		#' `FALSE`.
98		#'
99		#' @note `ID` and `cohort` can be missing. Then a message will be issued
100		#' and the variables will be filled with default IDs and best guesses cohort,
101		#' i.e. a sorted (in ascending order) sequence of values from `{1, 2, ...}`.
102		#'
103		#' @param x (`numeric`)\cr the doses for the patients.
104		#' @param y (`integer`)\cr the vector of toxicity events (0 or 1).
105		#' You can also supply `numeric` vectors, but these will then be converted to
106		#' `integer` internally.
107		#' @param ID (`integer`)\cr unique patient IDs.
108		#' You can also supply `numeric` vectors, but these will then be converted to
109		#' `integer` internally.
110		#' @param cohort (`integer`)\cr the cohort (non-negative sorted) indices.
111		#' You can also supply `numeric` vectors, but these will then be converted to
112		#' `integer` internally.
113		#' @param doseGrid (`numeric`)\cr all possible doses.
114		#' @param placebo (`flag`)\cr if `TRUE` the first dose level
115		#' in the `doseGrid` is considered as placebo.
116		#' @param ... not used.
117		#'
118		#' @export
119		#' @example examples/Data-class.R
120		#'
121		Data <- function(x = numeric(),
122		y = integer(),
123		ID = integer(),
124		cohort = integer(),
125		doseGrid = numeric(),
126		placebo = FALSE,
127		...) {
128	835x	assert_numeric(x)
129	835x	assert_integerish(y, lower = 0, upper = 1, any.missing = FALSE)
130	835x	assert_integerish(ID, unique = TRUE, any.missing = FALSE)
131	835x	assert_integerish(cohort)
132	835x	assert_numeric(doseGrid, any.missing = FALSE, unique = TRUE)
133	835x	assert_flag(placebo)
134
135	835x	doseGrid <- sort(doseGrid)
136	835x	assert_subset(x, doseGrid)
137
138	835x	if (length(ID) == 0 && length(x) > 0) {
139	1x	message("Used default patient IDs!")
140	1x	ID <- seq_along(x)
141		} else {
142	834x	assert_integerish(ID, unique = TRUE)
143		}
144
145	835x	if (!placebo && length(cohort) == 0 && length(x) > 0) {
146	1x	message("Used best guess cohort indices!")
147		# This is just assuming that consecutive patients
148		# in the data set are in the same cohort if they
149		# have the same dose. Note that this could be wrong,
150		# if two subsequent cohorts are at the same dose.
151	1x	cohort <- as.integer(c(1, 1 + cumsum(diff(x) != 0)))
152		} else {
153	834x	assert_integerish(cohort)
154		}
155
156	835x	.Data(
157	835x	x = as.numeric(x),
158	835x	y = as.integer(y),
159	835x	ID = as.integer(ID),
160	835x	cohort = as.integer(cohort),
161	835x	doseGrid = as.numeric(doseGrid),
162	835x	nObs = length(x),
163	835x	nGrid = length(doseGrid),
164	835x	xLevel = match_within_tolerance(x, doseGrid),
165	835x	placebo = placebo
166		)
167		}
168
169		## default constructor ----
170
171		#' @rdname Data-class
172		#' @note Typically, end users will not use the `.DefaultData()` function.
173		#' @export
174		.DefaultData <- function() {
175	12x	Data(
176	12x	doseGrid = c(1, 3, 5, 10, 15, 20, 25, 40, 50, 80, 100),
177	12x	ID = 1L:3L,
178	12x	cohort = 1L:3L,
179	12x	x = c(1, 3, 5),
180	12x	y = rep(0L, 3)
181		)
182		}
183
184		# DataDual ----
185
186		## class ----
187
188		#' `DataDual`
189		#'
190		#' @description `r lifecycle::badge("stable")`
191		#'
192		#' [`DataDual`] is a class for the dual endpoint data.
193		#' It inherits from [`Data`] and it contains additional biomarker information.
194		#'
195		#' @slot w (`numeric`)\cr the continuous vector of biomarker values.
196		#'
197		#' @aliases DataDual
198		#' @export
199		#'
200		.DataDual <- setClass(
201		Class = "DataDual",
202		slots = c(w = "numeric"),
203		prototype = prototype(w = numeric()),
204		contains = "Data",
205		validity = v_data_dual
206		)
207
208		## constructor ----
209
210		#' @rdname DataDual-class
211		#'
212		#' @param w (`numeric`)\cr the continuous vector of biomarker values.
213		#' @param ... parameters passed to [Data()].
214		#'
215		#' @export
216		#' @example examples/Data-class-DataDual.R
217		#'
218		DataDual <- function(w = numeric(),
219		...) {
220	170x	d <- Data(...)
221	170x	.DataDual(d, w = w)
222		}
223
224
225		## default constructor ----
226
227		#' @rdname DataDual-class
228		#' @note Typically, end users will not use the `.DefaultDataDual()` function.
229		#' @export
230		.DefaultDataDual <- function() {
231	4x	DataDual(
232	4x	x = c(0.1, 0.5, 1.5, 3, 6, 10, 10, 10),
233	4x	y = c(0, 0, 0, 0, 0, 0, 1, 0),
234	4x	w = rnorm(8),
235	4x	doseGrid = c(0.1, 0.5, 1.5, 3, 6, seq(from = 10, to = 80, by = 2)),
236	4x	ID = 1L:8L,
237	4x	cohort = as.integer(c(1, 2, 3, 4, 5, 6, 6, 6))
238		)
239		}
240
241		# DataParts ----
242
243		## class ----
244
245		#' `DataParts`
246		#'
247		#' @description `r lifecycle::badge("stable")`
248		#'
249		#' [`DataParts`] is a class for the data with two study parts.
250		#' It inherits from [`Data`] and it contains additional information
251		#' on the two study parts.
252		#'
253		#' @slot part (`integer`)\cr which part does each of the patients belong to?
254		#' @slot nextPart (`count`)\cr what is the part for the next cohort (1 or 2)?
255		#' @slot part1Ladder (`numeric`)\cr what is the escalation ladder for
256		#' part 1? This shall be an ordered subset of the `doseGrid`.
257		#'
258		#' @aliases DataParts
259		#' @export
260		#'
261		.DataParts <- setClass(
262		Class = "DataParts",
263		slots = c(
264		part = "integer",
265		nextPart = "integer",
266		part1Ladder = "numeric"
267		),
268		prototype = prototype(
269		part = integer(),
270		nextPart = 1L,
271		part1Ladder = numeric()
272		),
273		contains = "Data",
274		validity = v_data_parts
275		)
276
277		## constructor ----
278
279		#' @rdname DataParts-class
280		#'
281		#' @param part (`integer`)\cr which part does each of the patients belong to?
282		#' @param nextPart (`count`)\cr what is the part for the next cohort (1 or 2)?
283		#' @param part1Ladder (`numeric`)\cr what is the escalation ladder for part 1?
284		#' This shall be an ordered subset of the `doseGrid`.
285		#' @param ... parameters passed to [Data()].
286		#'
287		#' @export
288		#' @example examples/Data-class-DataParts.R
289		#'
290		DataParts <- function(part = integer(),
291		nextPart = 1L,
292		part1Ladder = numeric(),
293		...) {
294	25x	d <- Data(...)
295	25x	.DataParts(
296	25x	d,
297	25x	part = part,
298	25x	nextPart = nextPart,
299	25x	part1Ladder = part1Ladder
300		)
301		}
302
303		## default constructor ----
304
305		#' @rdname DataParts-class
306		#' @note Typically, end users will not use the `.DefaultDataParts()` function.
307		#' @export
308		.DefaultDataParts <- function() {
309	4x	DataParts(
310	4x	x = c(0.1, 0.5, 1.5),
311	4x	y = c(0, 0, 0),
312	4x	ID = 1:3,
313	4x	cohort = 1:3,
314	4x	doseGrid = c(0.1, 0.5, 1.5, 3, 6, seq(from = 10, to = 80, by = 2)),
315	4x	part = c(1L, 1L, 1L),
316	4x	nextPart = 1L,
317	4x	part1Ladder = c(0.1, 0.5, 1.5, 3, 6, 10)
318		)
319		}
320
321
322		# DataMixture ----
323
324		## class ----
325
326		#' `DataMixture`
327		#'
328		#' @description `r lifecycle::badge("stable")`
329		#'
330		#' [`DataMixture`] is a class for the data with mixture sharing.
331		#' It inherits from [`Data`] and it contains additional information
332		#' on the mixture sharing.
333		#'
334		#' @slot xshare (`numeric`)\cr the doses for the share patients.
335		#' @slot yshare (`integer`)\cr the vector of toxicity events (0 or 1)
336		#' for the share patients.
337		#' @slot nObsshare (`count`)\cr number of share patients.
338		#'
339		#' @aliases DataMixture
340		#' @export
341		#'
342		.DataMixture <- setClass(
343		Class = "DataMixture",
344		slots = c(
345		xshare = "numeric",
346		yshare = "integer",
347		nObsshare = "integer"
348		),
349		prototype = prototype(
350		xshare = numeric(),
351		yshare = integer(),
352		nObsshare = 0L
353		),
354		contains = "Data",
355		validity = v_data_mixture
356		)
357
358		## constructor ----
359
360		#' @rdname DataMixture-class
361		#'
362		#' @param xshare (`numeric`)\cr the doses for the share patients.
363		#' @param yshare (`integer`)\cr the vector of toxicity events (0 or 1)
364		#' for the share patients. You can also supply `numeric` vectors,
365		#' but these will then be converted to `integer` internally.
366		#' @param ... parameters passed to [Data()].
367		#'
368		#' @export
369		#' @example examples/Data-class-DataMixture.R
370		#'
371		DataMixture <- function(xshare = numeric(),
372		yshare = integer(),
373		...) {
374	6x	d <- Data(...)
375	6x	assert_integerish(yshare)
376	6x	assert_numeric(xshare)
377	6x	.DataMixture(
378	6x	d,
379	6x	xshare = as.numeric(xshare),
380	6x	yshare = as.integer(yshare),
381	6x	nObsshare = length(xshare)
382		)
383		}
384
385		## default constructor ----
386
387		#' @rdname DataMixture-class
388		#' @note Typically, end users will not use the `.DefaultDataMixture()` function.
389		#' @export
390		.DefaultDataMixture <- function() {
391	4x	DataMixture(
392	4x	xshare = c(12, 14, 16, 18.0),
393	4x	yshare = c(0L, 1L, 1L, 1L),
394	4x	nObsshare = 4L,
395	4x	x = c(0.1, 0.5, 1.5),
396	4x	y = c(0, 0, 0),
397	4x	ID = 1L:3L,
398	4x	cohort = 1L:3L,
399	4x	doseGrid = c(0.1, 0.5, 1.5, 3, 6, seq(from = 10, to = 80, by = 2))
400		)
401		}
402
403
404		# DataDA ----
405
406		## class ----
407
408		#' `DataDA`
409		#'
410		#' @description `r lifecycle::badge("stable")`
411		#'
412		#' [`DataDA`] is a class for the time-to-DLT augmented data.
413		#' It inherits from [`Data`] and it contains additional DLT free survival times.
414		#'
415		#' @note `survival time` here refers to the time period for which the subject
416		#' did not experience any DLT, and is not referring to deaths.
417		#'
418		#' @slot u (`numeric`)\cr the continuous vector of DLT free survival times.
419		#' @slot t0 (`numeric`)\cr time of initial dosing for each patient.
420		#' Non-negative values sorted in ascending order.
421		#' @slot Tmax (`number`)\cr the DLT observation period.
422		#'
423		#' @aliases DataDA
424		#' @export
425		#'
426		.DataDA <- setClass(
427		Class = "DataDA",
428		slots = c(
429		u = "numeric",
430		t0 = "numeric",
431		Tmax = "numeric"
432		),
433		prototype = prototype(
434		u = numeric(),
435		t0 = numeric(),
436		Tmax = 0 + .Machine$double.xmin
437		),
438		contains = "Data",
439		validity = v_data_da
440		)
441
442		## constructor ----
443
444		#' @rdname DataDA-class
445		#'
446		#' @param u (`numeric`)\cr the continuous vector of DLT free survival times.
447		#' @param t0 (`numeric`)\cr time of initial dosing for each patient.
448		#' Non-negative values sorted in ascending order.
449		#' Default to vector of 0s of length equal to length of `u`.
450		#' @param Tmax (`number`)\cr the DLT observation period.
451		#' @param ... parameters passed to [Data()].
452		#'
453		#' @export
454		#' @example examples/Data-class-DataDA.R
455		#'
456		DataDA <- function(u = numeric(),
457		t0 = numeric(length(u)),
458		Tmax = 0 + .Machine$double.xmin,
459		...) {
460	26x	d <- Data(...)
461	26x	.DataDA(
462	26x	d,
463	26x	u = as.numeric(u),
464	26x	t0 = as.numeric(t0),
465	26x	Tmax = as.numeric(Tmax)
466		)
467		}
468
469		## default constructor ----
470
471		#' @rdname DataDA-class
472		#' @note Typically, end users will not use the `.DefaultDataDA()` function.
473		#' @export
474		.DefaultDataDA <- function() {
475	5x	DataDA(
476	5x	u = c(42, 30, 15, 5, 20, 25, 30, 60),
477	5x	t0 = c(0, 15, 30, 40, 55, 70, 75, 85),
478	5x	Tmax = 60,
479	5x	x = c(0.1, 0.5, 1.5, 3, 6, 10, 10, 10),
480	5x	y = c(0, 0, 1, 1, 0, 0, 1, 0),
481	5x	doseGrid = c(0.1, 0.5, 1.5, 3, 6, seq(from = 10, to = 80, by = 2)),
482	5x	ID = 1L:8L,
483	5x	cohort = as.integer(c(1, 2, 3, 4, 5, 6, 6, 6))
484		)
485		}
486
487		# DataOrdinal ----
488
489		## class ----
490
491		#' `DataOrdinal`
492		#'
493		#' @description `r lifecycle::badge("experimental")`
494		#'
495		#' [`DataOrdinal`] is a class for ordinal toxicity data.
496		#' It inherits from [`GeneralData`] and it describes toxicity responses on an
497		#' ordinal rather than binary scale.
498		#'
499		#' @note This class has been implemented as a sibling of the existing `Data` class
500		#' (rather than as a parent or child) to minimise the risk of unintended side
501		#' effects on existing classes and methods.
502		#'
503		#' The default setting for the `yCategories` slot replicates the behaviour
504		#' of the existing `Data` class.
505		#'
506		#' @aliases DataOrdinal
507		#' @export
508		.DataOrdinal <- setClass(
509		Class = "DataOrdinal",
510		contains = "GeneralData",
511		slots = c(
512		x = "numeric",
513		y = "integer",
514		doseGrid = "numeric",
515		nGrid = "integer",
516		xLevel = "integer",
517		yCategories = "integer",
518		placebo = "logical"
519		),
520		prototype = prototype(
521		x = numeric(),
522		y = integer(),
523		doseGrid = numeric(),
524		nGrid = 0L,
525		xLevel = integer(),
526		yCategories = c("No DLT" = 0L, "DLT" = 1L),
527		placebo = FALSE
528		),
529		validity = v_data_ordinal
530		)
531
532		## constructor ----
533
534		#' @rdname DataOrdinal-class
535		#' @param yCategories (named `integer`)\cr the names and codes for the
536		#' toxicity categories used in the data. Category labels are taken from the
537		#' names of the vector. The names of the vector must be unique and its values
538		#' must be sorted and take the values 0, 1, 2, ...
539		#' @inheritParams Data
540		#' @inherit Data details note params
541		#' @example examples/Data-class-DataOrdinal.R
542		#' @export
543		DataOrdinal <- function(x = numeric(),
544		y = integer(),
545		ID = integer(),
546		cohort = integer(),
547		doseGrid = numeric(),
548		placebo = FALSE,
549		yCategories = c("No DLT" = 0L, "DLT" = 1L),
550		...) {
551	59x	assert_numeric(doseGrid, any.missing = FALSE, unique = TRUE)
552	59x	assert_integerish(
553	59x	yCategories,
554	59x	any.missing = FALSE,
555	59x	unique = TRUE,
556	59x	names = "unique",
557	59x	min.len = 2
558		)
559	59x	assert_flag(placebo)
560
561	59x	doseGrid <- as.numeric(sort(doseGrid))
562
563	59x	if (length(ID) == 0 && length(x) > 0) {
564	!	message("Used default patient IDs!")
565	!	ID <- seq_along(x)
566		} else {
567	59x	assert_integerish(ID, unique = TRUE)
568		}
569
570	59x	if (!placebo && length(cohort) == 0 && length(x) > 0) {
571	!	message("Used best guess cohort indices!")
572		# This is just assuming that consecutive patients
573		# in the data set are in the same cohort if they
574		# have the same dose. Note that this could be wrong,
575		# if two subsequent cohorts are at the same dose.
576	!	cohort <- as.integer(c(1, 1 + cumsum(diff(x) != 0)))
577		} else {
578	59x	assert_integerish(cohort)
579		}
580
581	59x	.DataOrdinal(
582	59x	x = as.numeric(x),
583	59x	y = as.integer(y),
584	59x	ID = as.integer(ID),
585	59x	cohort = as.integer(cohort),
586	59x	doseGrid = doseGrid,
587	59x	nObs = length(x),
588	59x	nGrid = length(doseGrid),
589	59x	xLevel = match_within_tolerance(x = x, table = doseGrid),
590	59x	placebo = placebo,
591	59x	yCategories = yCategories
592		)
593		}
594
595
596		## default constructor ----
597
598		#' @rdname DataOrdinal-class
599		#' @note Typically, end users will not use the `.DefaultDataOrdinal()` function.
600		#' @export
601		.DefaultDataOrdinal <- function() {
602	19x	DataOrdinal(
603	19x	x = c(10, 20, 30, 40, 50, 50, 50, 60, 60, 60),
604	19x	y = as.integer(c(0, 0, 0, 0, 0, 1, 0, 0, 1, 2)),
605	19x	ID = 1L:10L,
606	19x	cohort = as.integer(c(1:4, 5, 5, 5, 6, 6, 6)),
607	19x	doseGrid = c(seq(from = 10, to = 100, by = 10)),
608	19x	yCategories = c("No tox" = 0L, "Sub-tox AE" = 1L, "DLT" = 2L),
609	19x	placebo = FALSE
610		)
611		}
612
613		# DataGrouped ----
614
615		## class ----
616
617		#' `DataGrouped`
618		#'
619		#' @description `r lifecycle::badge("stable")`
620		#'
621		#' [`DataGrouped`] is a class for a two groups dose escalation data set,
622		#' comprised of a monotherapy (`mono`) and a combination therapy (`combo`)
623		#' arm. It inherits from [`Data`] and it contains the additional group information.
624		#'
625		#' @slot group (`factor`)\cr whether `mono` or `combo` was used.
626		#'
627		#' @aliases DataGrouped
628		#' @export
629		.DataGrouped <- setClass(
630		Class = "DataGrouped",
631		slots = c(
632		group = "factor"
633		),
634		prototype = prototype(
635		group = factor(levels = c("mono", "combo"))
636		),
637		contains = "Data",
638		validity = v_data_grouped
639		)
640
641		#' @rdname DataGrouped-class
642		#'
643		#' @param group (`factor` or `character`)\cr whether `mono` or `combo` was used.
644		#' If `character` then will be coerced to `factor` with the correct levels
645		#' internally.
646		#' @param ... parameters passed to [Data()].
647		#'
648		#' @export
649		#' @example examples/Data-class-DataGrouped.R
650		#'
651		DataGrouped <- function(group = character(),
652		...) {
653	59x	d <- Data(...)
654	59x	if (!is.factor(group)) {
655	59x	assert_character(group)
656	59x	assert_subset(group, choices = c("mono", "combo"))
657	59x	group <- factor(group, levels = c("mono", "combo"))
658		}
659	59x	.DataGrouped(
660	59x	d,
661	59x	group = group
662		)
663		}
664
665		## default constructor ----
666
667		#' @rdname DataGrouped-class
668		#' @note Typically, end users will not use the `.DefaultDataGrouped()` function.
669		#' @export
670		.DefaultDataGrouped <- function() {
671	5x	DataGrouped()
672		}

1		# GeneralSimulations ----
2
3		#' Internal Helper Functions for Validation of [`GeneralSimulations`] Objects
4		#'
5		#' @description `r lifecycle::badge("stable")`
6		#'
7		#' These functions are only used internally to validate the format of an input
8		#' [`GeneralSimulations`] or inherited classes and therefore not exported.
9		#'
10		#' @name v_general_simulations
11		#' @param object (`GeneralSimulations`)\cr object to validate.
12		#' @return A `character` vector with the validation failure messages,
13		#' or `TRUE` in case validation passes.
14		NULL
15
16		#' @describeIn v_general_simulations validates that the [`GeneralSimulations`] object
17		#' contains valid `data` object and valid `dose` simulations.
18
19		v_general_simulations <- function(object) {
20	!	v <- Validate()
21
22	!	nSims <- length(object@data)
23
24	!	v$check(
25	!	all(sapply(object@data, is, "Data")),
26	!	"all data elements must be Data objects"
27		)
28	!	v$check(
29	!	identical(length(object@doses), nSims),
30	!	"doses must have same length as the data list"
31		)
32
33	!	v$result()
34		}
35
36		#' @describeIn v_general_simulations validates that the [`Simulations`] object
37		#' contains valid object `fit`, `stop_reasons`, `stop_report`, and
38		#' `additional_stats` compared to the general class [`GeneralSimulations`].
39		#'
40		v_simulations <- function(object) {
41	!	v <- Validate()
42
43	!	nSims <- length(object@data)
44
45	!	v$check(
46	!	identical(length(object@fit), nSims),
47	!	"fit must have same length as data"
48		)
49	!	v$check(
50	!	identical(length(object@stop_reasons), nSims),
51	!	"stop_reasons must have same length as data"
52		)
53
54	!	v$check(
55	!	checkmate::test_matrix(object@stop_report,
56	!	mode = "logical",
57	!	nrows = nSims,
58	!	min.cols = 1,
59	!	any.missing = FALSE
60		),
61	!	"stop_report must be a matrix of mode logical in which the number of rows
62	!	equals the number of simulations and which must not contain any missing values"
63		)
64
65	!	v$result()
66		}
67
68		#' @describeIn v_general_simulations validates that the [`DualSimulations`] object and
69		#' capture the dose-biomarker `fits`, and the `sigma2W` and `rho` estimates.
70		#'
71		v_dual_simulations <- function(object) {
72	!	v <- Validate()
73
74	!	nSims <- length(object@data)
75
76	!	v$check(
77	!	identical(length(object@fit_biomarker), nSims),
78	!	"fit_biomarker list has to have same length as data"
79		)
80	!	v$check(
81	!	identical(length(object@rho_est), nSims),
82	!	"rho_est vector has to have same length as data"
83		)
84	!	v$check(
85	!	identical(length(object@sigma2w_est), nSims),
86	!	"sigma2w_est has to have same length as data"
87		)
88
89	!	v$result()
90		}
91
92		# PseudoSimulations ----
93
94		#' Internal Helper Functions for Validation of [`PseudoSimulations`] Objects
95		#'
96		#' @description `r lifecycle::badge("stable")`
97		#'
98		#' These functions are only used internally to validate the format of an input
99		#' [`PseudoSimulations`] or inherited classes and therefore not exported.
100		#'
101		#' @name v_pseudo_simulations
102		#' @param object (`PseudoSimulations`)\cr object to validate.
103		#' @return A `character` vector with the validation failure messages,
104		#' or `TRUE` in case validation passes.
105		NULL
106
107		#' @describeIn v_pseudo_simulations validates that the [`PseudoSimulations`] object
108		#' contains valid `fit`, `FinalTDtargetEndOfTrialEstimates` ,
109		#' `FinalTDtargetDuringTrialAtDoseGrid`,`FinalTDtargetEndOfTrialAtDoseGrid` ,
110		#' `FinalTDEOTCIs`, `FinalTDEOTRatios`, `FinalCIs`, `FinalRatios`,
111		#' object and valid `stopReasons` simulations.
112
113		v_pseudo_simulations <- function(object) {
114	!	v <- Validate()
115
116	!	nSims <- length(object@data)
117	!	v$check(
118	!	identical(length(object@stopReasons), nSims),
119	!	"stopReasons must have same length as data"
120		)
121
122	!	v$result()
123		}
124
125		#' @describeIn v_pseudo_simulations validates that the [`PseudoDualSimulations`] object
126		#' contains valid `fitEff`, `FinalGstarEstimates` , `FinalGstarAtDoseGrid`,
127		#' `FinalGstarCIs` , `FinalGstarRatios`, `FinalOptimalDose`, `FinalOptimalDoseAtDoseGrid`
128		#' object and valid `sigma2est` simulations.
129
130		v_pseudo_dual_simulations <- function(object) {
131	!	v <- Validate()
132	!	nSims <- length(object@data)
133	!	v$check(
134	!	identical(length(object@sigma2est), nSims),
135	!	"sigma2est has to have same length as data"
136		)
137	!	v$result()
138		}
139
140		#' @describeIn v_pseudo_simulations validates that the [`PseudoDualFlexiSimulations`]
141		#' object contains valid `sigma2betaWest` vector of the final posterior mean
142		#' sigma2betaW estimates.`FinalGstarEstimates` , `FinalGstarAtDoseGrid`,
143		#'
144		v_pseudo_dual_flex_simulations <- function(object) {
145	!	v <- Validate()
146	!	nSims <- length(object@data)
147	!	v$check(
148	!	identical(length(object@sigma2betaWest), nSims),
149	!	"sigma2betaWest has to have same length as data"
150		)
151	!	v$result()
152		}
153
154		#' @describeIn v_general_simulations validates that the [`DASimulations`] object
155		#' contains valid `trialduration` the vector of trial duration values for all
156		#' simulations.
157
158		v_da_simulations <- function(object) {
159	!	v <- Validate()
160
161	!	nSims <- length(object@data)
162
163	!	v$check(
164	!	identical(length(object@trialduration), nSims),
165	!	"trialduration vector has to have same length as data"
166		)
167
168	!	v$result()
169		}

1		#' Helper Function to Set and Save the RNG Seed
2		#'
3		#' @description `r lifecycle::badge("stable")`
4		#'
5		#' This code is basically copied from `stats:::simulate.lm`.
6		#'
7		#' @param seed an object specifying if and how the random number generator
8		#' should be initialized ("seeded"). Either `NULL` (default) or an
9		#' integer that will be used in a call to [set.seed()] before
10		#' simulating the response vectors. If set, the value is saved as the
11		#' `seed` slot of the returned object. The default, `NULL` will
12		#' not change the random generator state.
13		#' @return The integer vector containing the random number generate state will
14		#' be returned, in order to call this function with this input to reproduce
15		#' the obtained simulation results.
16		#'
17		#' @export
18		set_seed <- function(seed = NULL) {
19	33x	assert_number(seed, null.ok = TRUE)
20
21	33x	if (!exists(".Random.seed", envir = .GlobalEnv, inherits = FALSE)) {
22	1x	runif(1)
23		}
24
25	33x	if (is.null(seed)) {
26	4x	get(".Random.seed", envir = .GlobalEnv)
27		} else {
28	29x	seed <- as.integer(seed)
29	29x	r_seed <- get(".Random.seed", envir = .GlobalEnv)
30		# Make sure r_seed exists in parent frame.
31	29x	assign(".r_seed", r_seed, envir = parent.frame())
32	29x	set.seed(seed)
33		# Here we need the r_seed in the parent.frame!
34	29x	do.call(
35	29x	"on.exit",
36	29x	list(quote(assign(".Random.seed", .r_seed, envir = .GlobalEnv))),
37	29x	envir = parent.frame()
38		)
39	29x	structure(seed, kind = as.list(RNGkind()))
40		}
41		}
42
43		#' Helper Function to Obtain Simulation Results List
44		#'
45		#' The function `fun` can use variables that are visible to itself.
46		#' The names of these variables have to be given in the vector `vars`.
47		#'
48		#' @param fun (`function`)\cr the simulation function for a single iteration, which takes as
49		#' single parameter the iteration index.
50		#' @param nsim number of simulations to be conducted.
51		#' @param vars names of the variables.
52		#' @param parallel should the simulation runs be parallelized across the
53		#' clusters of the computer?
54		#' @param n_cores how many cores should be used for parallel computing?
55		#' @return The list with all simulation results (one iteration corresponds
56		#' to one list element).
57		#'
58		#' @importFrom parallel makeCluster
59		#' @importFrom parallelly availableCores
60		#' @keywords internal programming
61		get_result_list <- function(
62		fun,
63		nsim,
64		vars,
65		parallel,
66		n_cores) {
67	33x	assert_flag(parallel)
68	32x	assert_integerish(n_cores, lower = 1)
69
70	31x	if (!parallel) {
71	31x	lapply(
72	31x	X = seq_len(nsim),
73	31x	FUN = fun
74		)
75		} else {
76		# Process all simulations.
77	!	cores <- min(
78	!	as.integer(n_cores),
79	!	parallelly::availableCores()
80		)
81
82		# Start the cluster.
83	!	cl <- parallel::makeCluster(cores)
84
85		# Load the required R package.
86	!	parallel::clusterEvalQ(cl, {
87	!	library(crmPack)
88	!	NULL
89		})
90
91		# Export local variables from the caller environment.
92		# Note: parent.frame() is different from parent.env() which returns
93		# the environment where this function has been defined!
94	!	parallel::clusterExport(
95	!	cl = cl,
96	!	varlist = vars,
97	!	envir = parent.frame()
98		)
99
100		# Export all global variables.
101	!	parallel::clusterExport(
102	!	cl = cl,
103	!	varlist = ls(.GlobalEnv)
104		)
105
106		# Load user extensions from global options.
107	!	crmpack_extensions <- getOption("crmpack_extensions")
108	!	if (is.null(crmpack_extensions) != TRUE) {
109	!	tryCatch(
110		{
111	!	parallel::clusterCall(cl, crmpack_extensions)
112		},
113	!	error = function(e) {
114	!	stop("Failed to export crmpack_extensions: ", e$message)
115		}
116		)
117		}
118
119		# Do the computations in parallel.
120	!	res <- parallel::parLapply(
121	!	cl = cl,
122	!	X = seq_len(nsim),
123	!	fun = fun
124		)
125
126		# Stop the cluster.
127	!	parallel::stopCluster(cl)
128
129	!	res
130		}
131		}
132
133
134
135
136		#' Helper Function to call truth calculation
137		#'
138		#' @param dose (`number`)\cr current dose.
139		#' @param truth (`function`)\cr defines the true probability for a DLT at a dose.
140		#' @param this_args (`data.frame`)\cr list of arguments for the truth.
141		#' @return The updated `this_truth`.
142		#'
143		#' @keywords internal
144		h_this_truth <- function(dose, this_args, truth) {
145	118x	do.call(
146	118x	truth,
147		## First argument: the dose
148	118x	c(
149	118x	dose,
150		## Following arguments
151	118x	this_args
152		)
153		)
154		}
155
156
157		#' Helper Function to create return list for Simulations output
158		#'
159		#' @param resultList (`list`)\cr raw iteration output.
160		#'
161		#' @return aggregated output for simulation object `list`.
162		#'
163		#' @keywords internal
164		h_simulations_output_format <- function(resultList) {
165		## put everything in the Simulations format:
166
167		## setup the list for the simulated data objects
168	11x	dataList <- lapply(resultList, "[[", "data")
169
170		## the vector of the final dose recommendations
171	11x	recommendedDoses <- as.numeric(sapply(resultList, "[[", "dose"))
172
173		## setup the list for the final fits
174	11x	fitList <- lapply(resultList, "[[", "fit")
175
176		## the reasons for stopping
177	11x	stopReasons <- lapply(resultList, "[[", "stop")
178
179		# individual stopping rule results as matrix, labels as column names
180	11x	stopResults <- lapply(resultList, "[[", "report_results")
181	11x	stop_matrix <- as.matrix(do.call(rbind, stopResults))
182
183		# Result list of additional statistical summary.
184	11x	additional_stats <- lapply(resultList, "[[", "additional_stats")
185
186	11x	return(list(
187	11x	dataList = dataList,
188	11x	recommendedDoses = recommendedDoses,
189	11x	fitList = fitList,
190	11x	stopReasons = stopReasons,
191	11x	stopResults = stopResults,
192	11x	additional_stats = additional_stats,
193	11x	stop_matrix = stop_matrix
194		))
195		}
196
197
198		#' Helper function to recursively unpack stopping rules and return lists with
199		#' logical value and label given
200		#'
201		#' @param stopit_tree object from simulate method
202		#' @return named list
203
204		h_unpack_stopit <- function(stopit_tree) {
205	753x	label <- attr(stopit_tree, "report_label")
206	753x	value <- stopit_tree[1]
207	753x	names(value) <- label
208	753x	value
209	753x	if (is.null(attr(stopit_tree, "individual"))) {
210	550x	return(value)
211		} else {
212	203x	return(unlist(c(value, lapply(attr(stopit_tree, "individual"), h_unpack_stopit))))
213		}
214		}
215
216
217
218		#' Helper function to determine the dlts including first separate and placebo
219		#' condition
220		#'
221		#' @param data (`Data`)\cr what data to start from.
222		#' @param dose (`number`)\cr current dose.
223		#' @param prob (`function`)\cr defines the true probability for a DLT at a dose.
224		#' @param prob_placebo (`function`)\cr defines the true probability for a DLT at a placebo condition.
225		#' @param cohort_size (`number`)\cr the cohort size to use.
226		#' @param cohort_size_placebo (`number`)\cr the cohort size to use for placebo condition.
227		#' @param dose_grid (`numeric`)\cr the dose_grid as specified by the user.
228		#' @param first_separate (`flag`)\cr whether the first patient is enrolled separately.
229		#' @return updated data object
230		#' @keywords internal
231
232
233		h_determine_dlts <- function(data,
234		dose,
235		prob,
236		prob_placebo,
237		cohort_size,
238		cohort_size_placebo,
239		dose_grid,
240		first_separate) {
241	205x	assert_class(data, "Data")
242	205x	assert_number(dose)
243	205x	assert_number(prob)
244	205x	assert_number(cohort_size)
245	205x	assert_flag(first_separate)
246
247	205x	if (first_separate && cohort_size > 1) {
248	24x	dlts <- rbinom(n = 1, size = 1, prob = prob)
249	24x	if ((data@placebo) && cohort_size_placebo > 0) {
250	!	dlts_placebo <- rbinom(n = 1, size = 1, prob = prob_placebo)
251		}
252	24x	if (dlts == 0) {
253	18x	dlts <- c(dlts, rbinom(n = cohort_size - 1L, size = 1, prob = prob))
254	18x	if ((data@placebo) && cohort_size_placebo > 0) {
255	!	dlts_placebo <- c(dlts_placebo, rbinom(
256	!	n = cohort_size_placebo, # cohort_size_placebo - 1?
257	!	size = 1,
258	!	prob = prob_placebo
259		))
260		}
261		}
262		} else {
263	181x	dlts <- rbinom(n = cohort_size, size = 1, prob = prob)
264	181x	if ((data@placebo) && cohort_size_placebo > 0) {
265	6x	dlts_placebo <- rbinom(n = cohort_size_placebo, size = 1, prob = prob_placebo)
266		}
267		}
268
269
270	205x	if ((data@placebo) && cohort_size_placebo > 0) {
271	6x	this_data <- update(
272	6x	object = data,
273	6x	x = dose_grid,
274	6x	y = dlts_placebo,
275	6x	check = FALSE
276		)
277
278		## update the data with active dose
279	6x	this_data <- update(
280	6x	object = this_data,
281	6x	x = dose,
282	6x	y = dlts,
283	6x	new_cohort = FALSE
284		)
285		} else {
286		## update the data with this cohort
287	199x	this_data <- update(
288	199x	object = data,
289	199x	x = dose,
290	199x	y = dlts
291		)
292		}
293	205x	return(this_data)
294		}

1		# Design ----
2
3		#' Internal Helper Functions for Validation of [`RuleDesign`] Objects
4		#'
5		#' @description `r lifecycle::badge("stable")`
6		#'
7		#' These functions are only used internally to validate the format of an input
8		#' [`RuleDesign`] or inherited classes and therefore not exported.
9		#'
10		#' @name v_design
11		#' @param object (`RuleDesign`)\cr object to validate.
12		#' @return A `character` vector with the validation failure messages,
13		#' or `TRUE` in case validation passes.
14		NULL
15
16		#' @describeIn v_design validates that the [`RuleDesign`] object
17		#' contains valid `startingDose`.
18		v_rule_design <- function(object) {
19	10x	v <- Validate()
20	10x	v$check(
21	10x	test_number(object@startingDose, finite = TRUE),
22	10x	"startingDose must be a number"
23		)
24	10x	v$check(
25	10x	test_subset(object@startingDose, choices = object@data@doseGrid, empty.ok = FALSE),
26	10x	"startingDose must be included in data@doseGrid"
27		)
28	10x	v$result()
29		}
30
31		#' Internal Helper Functions for Validation of [`RuleDesignOrdinal`] Objects
32		#'
33		#' @description `r lifecycle::badge("experimental")`
34		#'
35		#' These functions are only used internally to validate the format of an input
36		#' [`RuleDesignOrdinal`] or inherited classes and therefore not exported.
37		#'
38		#' @name v_design
39		#' @param object (`RuleDesignOrdinal`)\cr object to validate.
40		#' @return A `character` vector with the validation failure messages,
41		#' or `TRUE` in case validation passes.
42		NULL
43
44		#' @describeIn v_design validates that the [`RuleDesignOrdinal`] object
45		#' contains valid `starting_dose`.
46		v_rule_design_ordinal <- function(object) {
47	!	v <- Validate()
48	!	v$check(
49	!	test_number(object@starting_dose, finite = TRUE),
50	!	"starting_dose must be a number"
51		)
52	!	v$check(
53	!	test_subset(object@starting_dose, choices = object@data@doseGrid, empty.ok = FALSE),
54	!	"starting_dose must be included in data@doseGrid"
55		)
56	!	v$result()
57		}
58
59
60		#' @describeIn v_design validates that the [`DesignGrouped`] object
61		#' contains valid flags.
62		v_design_grouped <- function(object) {
63	2x	v <- Validate()
64	2x	v$check(
65	2x	test_flag(object@first_cohort_mono_only),
66	2x	"first_cohort_mono_only must be a flag"
67		)
68	2x	v$check(
69	2x	test_flag(object@same_dose_for_all),
70	2x	"same_dose_for_all must be a flag"
71		)
72	2x	v$check(
73	2x	test_flag(object@same_dose_for_all),
74	2x	"same_dose_for_start must be a flag"
75		)
76	2x	v$check(
77	2x	test_flag(object@stop_mono_with_combo),
78	2x	"stop_mono_with_combo must be a flag"
79		)
80	2x	v$result()
81		}

1		#' Update [`DualEndpoint`] class model components with regard to biomarker
2		#' regression variance.
3		#'
4		#' @description `r lifecycle::badge("stable")`
5		#'
6		#' A simple helper function that takes [`DualEndpoint`] model existing components
7		#' (`priormodel`, `modelspecs`, `init`, `sample`), and updates them with regard to
8		#' to biomarker regression variance `sigma2W`.
9		#'
10		#' @param use_fixed (`flag`)\cr indicates whether a fixed value for the biomarker
11		#' regression variance `sigma2W` should be used or not. If `sigma2W` is not
12		#' supposed to be a fixed value, a prior distribution from the Inverse-Gamma
13		#' distribution will be used. See the details below, under `sigma2W` argument.
14		#' @param sigma2W (`numeric`)\cr the biomarker variance. Either a fixed value or
15		#' Inverse-Gamma distribution parameters, i.e. vector with two elements named
16		#' `a` and `b`.
17		#' @param comp (`list`)\cr a named list with model components that will be updated.
18		#' The names should be: `priormodel`, `modelspecs`, `init`, `sample`. For
19		#' definitions of the components, see [`GeneralModel`] class.
20		#' The `modelspecs` and `init` components on `comp` list are specified up to
21		#' the body of corresponding `GeneralModel@modelspecs` and `GeneralModel@init`
22		#' functions. These bodies are simply a lists itself.
23		#'
24		#' @return `list` with updated model components.
25		#'
26		#' @export
27		h_model_dual_endpoint_sigma2W <- function(use_fixed, # nolintr
28		sigma2W,
29		comp) {
30	204x	if (use_fixed) {
31	114x	assert_number(sigma2W, lower = 0 + .Machine$double.xmin, finite = TRUE)
32	112x	comp$modelspecs$precW <- 1 / sigma2W
33		} else {
34	90x	assert_true(h_test_named_numeric(sigma2W, permutation.of = c("a", "b")))
35	89x	comp$priormodel <- h_jags_join_models(
36	89x	comp$priormodel,
37	89x	function() {
38	!	precW ~ dgamma(precWa, precWb)
39		}
40		)
41	89x	comp$modelspecs$precWa <- sigma2W[["a"]]
42	89x	comp$modelspecs$precWb <- sigma2W[["b"]]
43	89x	comp$init$precW <- 1
44	89x	comp$sample <- c(comp$sample, "precW")
45		}
46	201x	comp
47		}
48
49		#' Update [`DualEndpoint`] class model components with regard to DLT and biomarker
50		#' correlation.
51		#'
52		#' @description `r lifecycle::badge("stable")`
53		#'
54		#' A simple helper function that takes [`DualEndpoint`] model existing components
55		#' (`priormodel`, `modelspecs`, `init`, `sample`), and updates them with regard to
56		#' DLT and biomarker correlation `rho`.
57		#'
58		#' @param use_fixed (`flag`)\cr indicates whether a fixed value for DLT and
59		#' biomarker correlation `rho` should be used or not. If `rho` is not supposed
60		#' to be a fixed value, a prior distribution from the scaled Beta family will
61		#' be used. See the details below, under `rho` argument.
62		#' @param rho (`numeric`)\cr DLT and biomarker correlation. It must be either a
63		#' fixed value (between `-1` and `1`), or a named vector with two elements,
64		#' named `a` and `b` for the Beta prior on the transformation
65		#' `kappa = (rho + 1) / 2`, which is in `(0, 1)`. For example, `a = 1, b = 1`
66		#' leads to a uniform prior on `rho`.
67		#' @param comp (`list`)\cr a named list with model components that will be updated.
68		#' The names should be: `priormodel`, `modelspecs`, `init`, `sample`. For
69		#' definitions of the components, see [`GeneralModel`] class.
70		#' The `modelspecs` and `init` components on `comp` list are specified up to
71		#' the body of corresponding `GeneralModel@modelspecs` and `GeneralModel@init`
72		#' functions. These bodies are simply a lists itself.
73		#'
74		#' @return A `list` with updated model components.
75		#'
76		#' @export
77		h_model_dual_endpoint_rho <- function(use_fixed,
78		rho,
79		comp) {
80	205x	rmin <- .Machine$double.xmin
81	205x	if (use_fixed) {
82	115x	assert_number(rho, lower = -1 + rmin, upper = 1 - rmin)
83	112x	comp$modelspecs$rho <- rho
84		} else {
85	90x	assert_true(h_test_named_numeric(rho, permutation.of = c("a", "b")))
86	89x	comp$priormodel <- h_jags_join_models(
87	89x	comp$priormodel,
88	89x	function() {
89	!	kappa ~ dbeta(rhoa, rhob)
90	!	rho <- 2 * kappa - 1
91		}
92		)
93	89x	comp$modelspecs$rhoa <- rho[["a"]]
94	89x	comp$modelspecs$rhob <- rho[["b"]]
95	89x	comp$init$kappa <- 0.5
96	89x	comp$sample <- c(comp$sample, "rho")
97		}
98	201x	comp
99		}
100
101		#' Update certain components of [`DualEndpoint`] model with regard to prior variance
102		#' factor of the random walk.
103		#'
104		#' @description `r lifecycle::badge("stable")`
105		#'
106		#' A simple helper function that takes [`DualEndpoint`] object and updates
107		#' `priormodel`, `modelspecs`, `init`, `sample` slots according to the random walk
108		#' variance.
109		#'
110		#' @param use_fixed (`flag`)\cr indicates whether a fixed value for
111		#' `sigma2betaW` should be used or not. If `sigma2betaW` is not supposed
112		#' to be a fixed value, a prior distribution from the Inverse-Gamma distribution
113		#' will be used. See the details below, under `sigma2betaW` argument.
114		#' @param sigma2betaW (`numeric`)\cr the prior variance factor of the random walk
115		#' prior for the biomarker model. Either a fixed value or Inverse-Gamma distribution
116		#' parameters, i.e. vector with two elements named `a` and `b`.
117		#' @param de (`DualEnpoint`)\cr dual endpoint model whose slots will be updated.
118		#'
119		#' @return A [`DualEndpoint`] model with updated `priormodel`, `modelspecs`,
120		#' `init`, `sample` slots.
121		#'
122		#' @seealso [`DualEndpointRW`].
123		#' @export
124		h_model_dual_endpoint_sigma2betaW <- function(use_fixed, # nolintr
125		sigma2betaW,
126		de) {
127	56x	modelspecs <- de@modelspecs
128	56x	init <- de@init
129
130	56x	if (use_fixed) {
131	44x	assert_number(sigma2betaW, lower = 0 + .Machine$double.xmin, finite = TRUE)
132	42x	ms <- list(precBetaW = 1 / sigma2betaW)
133		} else {
134	12x	assert_true(h_test_named_numeric(sigma2betaW, permutation.of = c("a", "b")))
135		# gamma prior for random walk precision.
136	11x	de@priormodel <- h_jags_join_models(
137	11x	de@priormodel,
138	11x	function() {
139	!	precBetaW ~ dgamma(precBetaWa, precBetaWb)
140		}
141		)
142	11x	ms <- list(precBetaWa = sigma2betaW[["a"]], precBetaWb = sigma2betaW[["b"]])
143	11x	de@init <- function(y) {
144	10x	c(init(y), list(precBetaW = 1))
145		}
146	11x	de@sample <- c(de@sample, "precBetaW")
147		}
148	53x	de@modelspecs <- function(from_prior) {
149	36x	c(modelspecs(from_prior), ms)
150		}
151	53x	de
152		}
153
154		#' Update certain components of [`DualEndpoint`] model with regard to parameters
155		#' of the function that models dose-biomarker relationship defined in the
156		#' [`DualEndpointBeta`] class.
157		#'
158		#' @description `r lifecycle::badge("stable")`
159		#'
160		#' A simple helper function that takes [`DualEndpoint`] object and updates
161		#' `use_fixed`, `priormodel`, `modelspecs`, `init`, `sample` slots with regard
162		#' to a given parameter of the dose-biomarker relationship \eqn{f(x)} defined in
163		#' the [`DualEndpointBeta`] class. This update solely depends on whether a given
164		#' parameter's value `param` is a fixed-valued scalar or two-elements numeric
165		#' vector. In the later case, it is assumed that `param` represents two
166		#' parameters of a probability distribution that will be used in `priormodel`
167		#' function to generate values for the `param_name` parameter of \eqn{f(x)}.
168		#' See the help page for [`DualEndpointBeta`] class for more details.
169		#'
170		#' @param param (`numeric`)\cr the value of a given `param_name` parameter of
171		#' the dose-biomarker relationship function \eqn{f(x)}. Either a fixed-valued
172		#' scalar or vector with two elements that are the parameters of a probability
173		#' distribution that will be used in `priormodel` function to generate values
174		#' for the `param_name` parameter of \eqn{f(x)}.
175		#' @param param_name (`string`)\cr the name of the parameter of \eqn{f(x)},
176		#' whose value depends on `param`.
177		#' @param param_suffix (`character`)\cr the two suffixes to be appended to
178		#' the elements of `param_name` and then used when updating `modelspecs`.
179		#' The value of this argument is ignored when `param` is a scalar.
180		#' @param priormodel (`function` or `NULL`)\cr a function representing the
181		#' `JAGS` prior specification that will be appended to existing
182		#' `de@priormodel` specification if `param` is not a scalar. Otherwise,
183		#' `de@priormodel` remains unchanged.
184		#' @param de (`DualEnpoint`)\cr dual endpoint model whose slots will be updated.
185		#'
186		#' @return A [`DualEndpoint`] model with updated `use_fixed`, `priormodel`,
187		#' `modelspecs`, `init`, `sample` slots.
188		#'
189		#' @export
190		h_model_dual_endpoint_beta <- function(param,
191		param_name,
192		param_suffix = c("_low", "_high"),
193		priormodel = NULL,
194		de) {
195	176x	assert_numeric(param, min.len = 1, max.len = 2, any.missing = FALSE)
196	175x	assert_string(param_name)
197	174x	assert_class(de, "DualEndpoint")
198
199	174x	use_fixed <- setNames(test_number(param), param_name)
200	174x	modelspecs <- de@modelspecs
201	174x	init <- de@init
202
203	174x	if (use_fixed) {
204	81x	ms <- setNames(list(param), param_name)
205		} else {
206	93x	assert_character(param_suffix, len = 2, unique = TRUE, any.missing = FALSE)
207	92x	assert_function(priormodel)
208	91x	param_name2 <- paste0(param_name, param_suffix)
209
210	91x	de@priormodel <- h_jags_join_models(
211	91x	de@priormodel,
212	91x	priormodel
213		)
214	91x	ms <- setNames(list(param[1], param[2]), param_name2)
215	91x	de@init <- function(y) {
216	21x	c(init(y), setNames(list(mean(param)), param_name))
217		}
218	91x	de@sample <- c(de@sample, param_name)
219		}
220	172x	de@modelspecs <- function(from_prior) {
221	60x	c(modelspecs(from_prior), ms)
222		}
223	172x	de@use_fixed <- c(de@use_fixed, use_fixed)
224	172x	de
225		}
226
227		#' Convert an ordinal CRM model to the Equivalent Binary CRM Model for a Specific
228		#' Grade
229		#'
230		#' @description `r lifecycle::badge("experimental")`
231		#'
232		#' A simple helper function that takes a [`LogisticLogNormalOrdinal`] and an
233		#' integer grade and converts them to the equivalent `LogisticLogNormal` model.
234		#'
235		#' @param x (`LogisticLogNormalOrdinal`)\cr the `LogisticLogNormalOrdinal`
236		#' model to covert
237		#' @param grade (`integer`)\cr the toxicity grade for which the equivalent model
238		#' is required.
239		#' @return A [`LogisticLogNormal`] model.
240		#'
241		#' @export
242		h_convert_ordinal_model <- function(x, grade) {
243		# Validate
244	21x	assert_integer(grade, len = 1, lower = 1)
245	21x	assert_class(x, "LogisticLogNormalOrdinal")
246		# Execute
247	21x	LogisticLogNormal(
248	21x	mean = x@params@mean[-grade],
249	21x	cov = x@params@cov[-grade, -grade],
250	21x	ref_dose = x@ref_dose
251		)
252		}

1		#' @importFrom knitr knit_print
2		NULL
3
4		# Integration with knitr ----
5		#'
6		#' @description `r lifecycle::badge("experimental")`
7		#'
8		#' We provide additional utility functions to allow human-friendly rendition of
9		#' crmPack objects in Markdown and Quarto files
10		#'
11		#' @return a character string that represents the object in markdown.
12		#' @name knit_print
13		NULL
14
15		# CohortSize ----
16
17		#' Render a CohortSizeConst Object
18		#'
19		#' @description `r lifecycle::badge("experimental")`
20		#' @param x (`CohortSize`)\cr The object to knit_print.
21		#' @param asis (`flag`)\cr Should the return value be wrapped in a call to `knitr::asis_output`?
22		#' @param label (`character`)\cr The word used to label the participants. See Usage Notes below.
23		#' @param ... Not used at present
24		#'
25		#' @section Usage Notes:
26		#' `label` describes the trial's participants.
27		#'
28		#' It should be a character vector of length 1 or 2. If of length 2, the first
29		#' element describes a `cohort_size` of 1 and the second describes all other
30		#' `cohort_size`s. If of length 1, the character `s` is appended to the value
31		#' when `cohort_size` is not 1.
32		#' @return The markdown representation of the object, as a character string
33		#' @seealso [`knit_print`] for more details.
34		#'
35		#' @export
36		#' @rdname knit_print
37		knit_print.CohortSizeConst <- function(x, ..., asis = TRUE, label = c("participant", "participants")) {
38	7x	assert_character(label, min.len = 1, max.len = 2, any.missing = FALSE)
39	7x	assert_flag(asis)
40
41	7x	if (length(label) == 1) {
42	2x	label[2] <- paste0(label[1], "s")
43		}
44	7x	rv <- paste0("A constant size of ", x@size, " ", label[ifelse(x@size == 1, 1, 2)], ".")
45	7x	if (asis) {
46	5x	rv <- knitr::asis_output(rv)
47		}
48	7x	rv
49		}
50
51		#' Render a CohortSizeRange Object
52		#'
53		#' @description `r lifecycle::badge("experimental")`
54		#' @param ... passed to `knitr::kable`
55		#' @inherit knit_print.CohortSizeConst return
56		#' @section Usage Notes:
57		#' The default value of `col.names` is `c("Lower", "Upper", "Cohort size")` and
58		#' that of `caption` is `"Defined by the dose to be used in the next cohort"`.
59		#' These values can be overridden by passing `col.names` and `caption` in the
60		#' function call.
61		#' @export
62		#' @rdname knit_print
63		knit_print.CohortSizeRange <- function(x, ..., asis = TRUE) {
64	12x	assert_flag(asis)
65
66	12x	param <- list(...)
67	12x	if (!("col.names" %in% names(param))) {
68	12x	param[["col.names"]] <- c("Lower", "Upper", "Cohort size")
69		}
70	12x	if (!("caption" %in% names(param))) {
71	12x	param[["caption"]] <- "Defined by the dose to be used in the next cohort"
72		}
73	12x	x <- tidy(x)
74	12x	param[["x"]] <- x
75	12x	rv <- kableExtra::add_header_above(
76	12x	do.call(knitr::kable, param),
77	12x	c("Dose" = 2, " " = 1)
78		)
79	12x	if (asis) {
80	8x	rv <- knitr::asis_output(rv)
81		}
82	12x	rv
83		}
84
85		#' Render a CohortSizeDLT Object
86		#'
87		#' @description `r lifecycle::badge("experimental")`
88		#' @inherit knit_print.CohortSizeConst return
89		#' @param ... Passed to `knitr::kable`.
90		#'
91		#' @section Usage Notes:
92		#' The by default, the columns are labelled `Lower`, `Upper` and `Cohort size`. The table's caption is
93		#' `Defined by the number of DLTs so far observed`. These values can be overridden by passing
94		#' `col.names` and `caption` in the function call.
95		#'
96		#' @export
97		#' @rdname knit_print
98		knit_print.CohortSizeDLT <- function(x, ..., asis = TRUE) {
99	9x	assert_flag(asis)
100
101	9x	param <- list(...)
102	9x	if (!("col.names" %in% names(param))) {
103	9x	param[["col.names"]] <- c("Lower", "Upper", "Cohort size")
104		}
105	9x	if (!("caption" %in% names(param))) {
106	9x	param[["caption"]] <- "Defined by the number of DLTs so far observed"
107		}
108	9x	param[["x"]] <- tidy(x)
109	9x	rv <- kableExtra::add_header_above(
110	9x	do.call(knitr::kable, param),
111	9x	c("No of DLTs" = 2, " " = 1)
112		)
113	9x	if (asis) {
114	6x	rv <- knitr::asis_output(rv)
115		}
116	9x	rv
117		}
118
119		#' Render a CohortSizeParts Object
120		#'
121		#' @description `r lifecycle::badge("experimental")`
122		#' @inherit knit_print.CohortSizeConst return
123		#' @inheritSection knit_print.CohortSizeConst Usage Notes
124		#'
125		#' @export
126		#' @rdname knit_print
127		knit_print.CohortSizeParts <- function(x, ..., asis = TRUE, label = c("participant", "participants")) {
128	8x	assert_character(label, min.len = 1, max.len = 2, any.missing = FALSE)
129	8x	assert_flag(asis)
130
131	8x	if (length(label) == 1) {
132	2x	label[2] <- paste0(label[1], "s")
133		}
134	8x	rv <- paste0(
135	8x	"A size of ",
136	8x	x@cohort_sizes[1],
137		" ",
138	8x	label[ifelse(x@cohort_sizes[1] == 1, 1, 2)],
139	8x	" in the first part and ",
140	8x	x@cohort_sizes[2],
141		" ",
142	8x	label[ifelse(x@cohort_sizes[2] == 1, 1, 2)],
143	8x	" in the second."
144		)
145	8x	if (asis) {
146	6x	rv <- knitr::asis_output(rv)
147		}
148	8x	rv
149		}
150
151		#' Render a CohortSizeMax Object
152		#'
153		#' @description `r lifecycle::badge("experimental")`
154		#' @inherit knit_print.CohortSizeConst return
155		#' @param ... passed through to the `knit_print` methods of the constituent
156		#' rules
157		#'
158		#' @export
159		#' @rdname knit_print
160		knit_print.CohortSizeMax <- function(x, ..., asis = TRUE) {
161	3x	assert_flag(asis)
162	3x	rv <- paste0(
163	3x	"The maximum of the cohort sizes defined in the following rules:",
164	3x	paste0(
165	3x	lapply(
166	3x	x@cohort_sizes,
167	3x	function(x, ...) {
168	6x	knit_print(x, asis = asis, ...)
169		}
170		),
171	3x	collapse = "\n"
172		),
173	3x	paste = "\n"
174		)
175
176	3x	if (asis) {
177	2x	rv <- knitr::asis_output(rv)
178		}
179	3x	rv
180		}
181
182		#' Render a CohortSizeMin Object
183		#'
184		#' @description `r lifecycle::badge("experimental")`
185		#' @inherit knit_print.CohortSizeConst return
186		#' @param ... passed through to the `knit_print` methods of the constituent
187		#' rules
188		#'
189		#' @export
190		#' @rdname knit_print
191		knit_print.CohortSizeMin <- function(x, ..., asis = TRUE) {
192	3x	assert_flag(asis)
193	3x	rv <- paste0(
194	3x	"The minimum of the cohort sizes defined in the following rules:",
195	3x	paste0(
196	3x	lapply(
197	3x	x@cohort_sizes,
198	3x	function(x, ...) {
199	6x	knit_print(x, asis = asis, ...)
200		}
201		),
202	3x	collapse = "\n"
203		),
204	3x	paste = "\n"
205		)
206	3x	if (asis) {
207	2x	rv <- knitr::asis_output(rv)
208		}
209	3x	rv
210		}
211
212		#' Render a CohortSizeOrdinal Object
213		#'
214		#' @description `r lifecycle::badge("experimental")`
215		#' @inherit knit_print.CohortSizeConst return
216		#' @param ... passed through to the `knit_print` method of the standard rule
217		#'
218		#' @export
219		#' @rdname knit_print
220		knit_print.CohortSizeOrdinal <- function(x, ..., asis = TRUE) {
221	3x	rv <- paste0(
222	3x	"Based on a toxicity grade of ",
223	3x	x@grade,
224		": ",
225	3x	paste0(knit_print(x@rule, asis = asis, ...), collapse = "\n"),
226	3x	paste = "\n"
227		)
228
229	3x	if (asis) {
230	2x	rv <- knitr::asis_output(rv)
231		}
232	3x	rv
233		}

1		#' Verbose Logging
2		#'
3		#' @description `r lifecycle::badge("experimental")`
4		#'
5		#' A family of wrappers of selected [`futile.logger`] functions that control
6		#' the logging mechanism in `crmPack`. The `crmPack` uses [`futile.logger`]
7		#' package for the logging purposes. All the messages logged in `crmPack` are
8		#' logged into `crmPack` logger at the [`futile.logger::TRACE`] level. Hence,
9		#' enabling verbose logging means that the logging threshold will be set to
10		#' [`futile.logger::TRACE`] for the `crmPack` logger, and disabling verbose
11		#' logging means that it will be set to [`futile.logger::FATAL`].
12		#'
13		#' @describeIn enable_logging A simple wrapper of
14		#' [futile.logger::flog.threshold()] that enables `crmPack` verbose logging by
15		#' setting logging threshold to [`futile.logger::TRACE`] for `crmPack` logger.
16		#'
17		#' @export
18		#'
19		enable_logging <- function() {
20	3x	invisible(
21	3x	futile.logger::flog.threshold(futile.logger::TRACE, name = "crmPack")
22		)
23		}
24
25		#' @describeIn enable_logging A simple wrapper of
26		#' [futile.logger::flog.threshold()] that disables `crmPack` verbose logging
27		#' by setting logging threshold to [`futile.logger::FATAL`] for `crmPack`
28		#' logger.
29		#'
30		#' @export
31		#'
32		disable_logging <- function() {
33	6x	invisible(
34	6x	futile.logger::flog.threshold(futile.logger::FATAL, name = "crmPack")
35		)
36		}
37
38		#' @describeIn enable_logging A simple wrapper of
39		#' [futile.logger::flog.logger()] that checks whether current threshold level
40		#' for `crmPack` logger is verbose, which is [`futile.logger::TRACE`].
41		#' It returns `TRUE` if the current logging level is verbose, `FALSE`
42		#' otherwise.
43		#'
44		#' @export
45		#'
46		is_logging_enabled <- function() {
47	947x	logger <- futile.logger::flog.logger(name = "crmPack")
48	947x	unname(logger$threshold == futile.logger::TRACE)
49		}
50
51		#' @describeIn enable_logging A simple wrapper of
52		#' [futile.logger::flog.trace()] that prints a log message in the `crmPack`
53		#' logger.
54		#'
55		#' @inheritParams futile.logger::flog.trace
56		#'
57		#' @export
58		#'
59		log_trace <- function(msg, ..., capture = FALSE) {
60	1445x	assert_string(msg)
61	1445x	assert_flag(capture)
62
63	1445x	futile.logger::flog.trace(msg = msg, ..., name = "crmPack", capture = capture)
64		}

1		#' @include helpers.R
2		NULL
3
4		#' Appending a Dummy Number for Selected Slots in Data
5		#'
6		#' @description `r lifecycle::badge("experimental")`
7		#'
8		#' A helper function that appends a dummy value to a given slots in [`GeneralData`]
9		#' class object, if and only if the total number of observations (as indicated
10		#' by `object@nObs`) equals to `1`. Otherwise, the `object` is not changed.
11		#'
12		#' @note The main motivation behind this function is related to the `JAGS`.
13		#' If there is only one observation, the data is not passed correctly to
14		#' `JAGS`, i.e. e.g. `x` and `y` are treated like scalars in the data file.
15		#' Therefore it is necessary to add dummy values to the vectors in this case
16		#' As we don't change the number of observations (`nObs`), this addition of
17		#' zeros doesn't affect the results of `JAGS` computations.
18		#'
19		#' @param object (`GeneralData`)\cr object into which dummy values will be added.
20		#' @param where (`character`)\cr names of slots in `object` to which a `dummy`
21		#' number will be appended.
22		#' @param dummy (`number`)\cr a dummy number that will be appended to selected
23		#' slots in `object`. Default to `0`.
24		#'
25		#' @return A [`GeneralData`] object with slots updated with dummy number.
26		#'
27		#' @export
28		#' @example examples/helpers-jags_add_dummy.R
29		#'
30		h_jags_add_dummy <- function(object, where, dummy = 0) {
31	480x	assert_class(object, "GeneralData")
32	480x	assert_character(where)
33	480x	assert_subset(where, slotNames(object))
34	479x	assert_number(dummy)
35
36	479x	if (object@nObs == 1L) {
37	16x	for (i in where) {
38		# Add dummy value and preserve the class.
39	41x	slot(object, i) <- as(c(slot(object, i), dummy), class(slot(object, i)))
40		}
41		}
42	479x	object
43		}
44
45		#' Joining `JAGS` Models
46		#'
47		#' @description `r lifecycle::badge("stable")`
48		#'
49		#' This helper function joins two JAGS models in the way that the body of the
50		#' second model is appended to the body of the first model (in this order).
51		#' After that, the first, body-extended model is returned. The arguments of
52		#' `model1`, `model2` model functions (if any) are not combined in any way.
53		#'
54		#' @note `model1` and `model2` functions must have a multi-expression
55		#' body, i.e. braced expression(s). Environments or any attributes of the
56		#' function bodies are not preserved in any way after joining.
57		#'
58		#' @param model1 (`function`)\cr the first model to join.
59		#' @param model2 (`function`)\cr the second model to join.
60		#'
61		#' @return joined models.
62		#'
63		#' @export
64		#'
65		h_jags_join_models <- function(model1, model2) {
66	845x	assert_function(model1)
67	845x	assert_function(model2)
68	845x	assert_class(body(model1), "{")
69	844x	assert_class(body(model2), "{")
70
71		# This workaround is needed to avoid bugs related to covr-injected code.
72	844x	if (h_covr_active()) {
73	844x	body(model2) <- h_covr_detrace(body(model2))
74		}
75
76	844x	body2 <- as.list(body(model2))
77	844x	if (length(body2) >= 2) {
78	843x	body1 <- as.list(body(model1))
79	843x	body(model1) <- as.call(c(body1, body2[-1]))
80		}
81	844x	model1
82		}
83
84
85		#' Setting Initial Values for `JAGS` Model Parameters
86		#'
87		#' @description `r lifecycle::badge("experimental")`
88		#'
89		#' A simple helper function that prepares an object for `inits` argument of
90		#' [rjags::jags.model()], which is invoked by [mcmc()] method. The `inits`
91		#' argument specifies initial values for model parameters.
92		#'
93		#' @param model (`GeneralModel`)\cr an input model.
94		#' @param data (`GeneralData`)\cr an input data.
95		#'
96		#' @return A `list` of starting values for parameters required to be initialized
97		#' in the MCMC `JAGS `sampler.
98		#'
99		#' @export
100		#' @example examples/helpers-jags_get_model_inits.R
101		#'
102		h_jags_get_model_inits <- function(model, data) {
103	473x	assert_class(model, "GeneralModel")
104	473x	assert_class(data, "GeneralData")
105
106	473x	inits <- do.call(model@init, h_slots(data, formalArgs(model@init)))
107	473x	assert_list(inits)
108	472x	inits[sapply(inits, length) > 0L]
109		}
110
111		#' Getting Data for `JAGS`
112		#'
113		#' @description `r lifecycle::badge("experimental")`
114		#'
115		#' A simple helper function that prepares an object for `data` argument of
116		#' [rjags::jags.model()], which is invoked by [mcmc()] method.
117		#'
118		#' @param model (`GeneralModel`)\cr an input model.
119		#' @param data (`GeneralData`)\cr an input data.
120		#' @param from_prior (`flag`)\cr sample from the prior only? In this case
121		#' data will not be appended to the output, i.e. only the variables required
122		#' by the `model@priormodel` model will be returned in data.
123		#'
124		#' @export
125		#' @example examples/helpers-jags_get_data.R
126		#'
127		h_jags_get_data <- function(model, data, from_prior) {
128	476x	assert_class(model, "GeneralModel")
129	476x	assert_class(data, "GeneralData")
130	476x	assert_flag(from_prior)
131
132		# 1) Extract variables from `data` as required by `modelspecs`.
133	476x	ms_args_names <- formalArgs(model@modelspecs)
134	476x	ms_args <- if ("from_prior" %in% ms_args_names) {
135	447x	c(h_slots(data, setdiff(ms_args_names, "from_prior")), list(from_prior = from_prior))
136		} else {
137	29x	h_slots(data, ms_args_names)
138		}
139	476x	modelspecs <- do.call(model@modelspecs, ms_args)
140	476x	assert_list(modelspecs)
141
142		# 2) Extract variables from `data` as required by `datanames`.
143	475x	datanames <- if (from_prior) {
144	40x	model@datanames_prior
145		} else {
146	435x	union(model@datanames, model@datanames_prior)
147		}
148
149		# Add dummy to ensure that e.g. `x` and `y` in `data` won't be treated as
150		# scalars by `JAGS` if `data@nObs == 1`, which leads to failures.
151	475x	add_where <- setdiff(datanames, c("nObs", "nGrid", "nObsshare", "yshare", "xshare", "Tmax"))
152	475x	data <- h_jags_add_dummy(data, where = add_where)
153
154	475x	data_model <- h_slots(data, datanames)
155	475x	c(data_model, modelspecs)
156		}
157
158		#' Writing JAGS Model to a File
159		#'
160		#' @description `r lifecycle::badge("stable")`
161		#'
162		#' This function converts a R function with JAGS model into a text and then
163		#' writes it into a given file. During the "model into text" conversion, the
164		#' format of numbers of which absolute value is less than `0.001` or greater
165		#' than `10000` is changed. These numbers will be converted into scientific
166		#' format with specified number of significant digits using [formatC()]
167		#' function.
168		#'
169		#' @note JAGS syntax allows truncation specification like `dnorm(...) I(...)`,
170		#' which is illegal in R. To overcome this incompatibility, use dummy operator
171		#' `\%_\%` before `I(...)`, i.e. `dnorm(...) \%_\% I(...)` in the model's
172		#' code. This dummy operator `\%_\%` will be removed just before saving the
173		#' JAGS code into a file.
174		#' Due to technical issues related to conversion of numbers to scientific
175		#' format, it is required that the body of a model function does not contain
176		#' `TEMP_NUM_PREF_` or `_TEMP_NUM_SUF` character constants in its body.
177		#'
178		#' @param model (`function`)\cr function containing the JAGS model.
179		#' @param file (`string` or `NULL`)\cr the name of the file (including the
180		#' optional path) where the model will be saved. If `NULL`, the file will be
181		#' created in a `R_crmPack` folder placed under temporary directory indicated
182		#' by [tempdir()] function.
183		#' @param digits (`count`)\cr a desired number of significant digits for
184		#' for numbers used in JAGS input, see [formatC()].
185		#' @return The name of the file where the model was saved.
186		#'
187		#' @export
188		#' @example examples/helpers-jags_write_model.R
189		#'
190		h_jags_write_model <- function(model, file = NULL, digits = 5) {
191	502x	assert_function(model)
192	502x	assert_count(digits)
193
194		# This workaround is needed to avoid bugs related to covr-injected code.
195	502x	if (h_covr_active()) {
196	502x	body(model) <- h_covr_detrace(body(model))
197		}
198
199	502x	if (!is.null(file)) {
200	1x	assert_path_for_output(file)
201		} else {
202	501x	dir <- file.path(tempdir(), "R_crmPack")
203		# Don't warn, as the temp dir often exists (which is OK).
204	501x	dir.create(dir, showWarnings = FALSE)
205	501x	file <- tempfile(
206	501x	pattern = "jags_model_fun",
207	501x	tmpdir = dir,
208	501x	fileext = ".txt"
209		)
210		}
211
212		# Replace scientific notation.
213	502x	model_sci_replaced <- h_rapply(
214	502x	x = body(model),
215	502x	fun = h_format_number,
216	502x	classes = c("integer", "numeric"),
217	502x	digits = digits,
218	502x	prefix = "TEMP_NUM_PREF_",
219	502x	suffix = "_TEMP_NUM_SUF"
220		)
221		# Transform `model` body into character vector.
222	502x	model_text <- deparse(model_sci_replaced, control = NULL)
223	502x	model_text <- gsub("\"TEMP_NUM_PREF_\|_TEMP_NUM_SUF\"", "", model_text)
224	502x	model_text <- gsub("%_% ", "", model_text)
225	502x	model_text <- c("model", model_text)
226
227	502x	log_trace("Writting JAGS model function into: %s", file)
228	502x	writeLines(model_text, con = file)
229	502x	file
230		}
231
232		#' Extracting Samples from `JAGS` `mcarray` Object
233		#'
234		#' @description `r lifecycle::badge("stable")`
235		#'
236		#' A simple helper function that extracts a sample from
237		#' [`rjags::mcarray.object`] S3 class object. The [`rjags::mcarray.object`]
238		#' object is used by the [rjags::jags.samples()] function to represent MCMC
239		#' output from a `JAGS` model.
240		#'
241		#' @param x an [`rjags::mcarray.object`] object.
242		#'
243		#' @export
244		#'
245		h_jags_extract_samples <- function(x) {
246	1292x	assert_class(x, "mcarray")
247
248	1292x	x <- x[, , 1L]
249		# In case that there are multiple parameters in a node.
250	1292x	if (is.matrix(x)) {
251	244x	x <- t(x)
252		}
253	1292x	x
254		}

1		#' Helper Function to Blind Plot Data
2		#'
3		#' @param df (`GeneralData`)\cr The data to be blinded
4		#' @param blind (`flag`)\cr Should the data be blinded?
5		#' @param has_placebo (`flag`)\cr Does the data contain a placebo dose?
6		#' @param pbo_dose (`positive_number`)\cr The dose to be taken as placebo.
7		#' Ignored if `has_placebo` is `FALSE`
8		#' @returns The blinded data
9		h_blind_plot_data <- function(df, blind, has_placebo, pbo_dose) {
10	19x	if (blind) {
11		# This is to blind the data.
12		# For each cohort, all DLTs are assigned to the first subjects in the cohort.
13		# In addition, the placebo (if any) is set to the active dose level for that
14		# cohort.
15		# Notice: dapply reorders records of df according to the lexicographic order
16		# of cohort.
17	9x	df <- dapply(df, f = ~cohort, FUN = function(coh) {
18	30x	coh$toxicity <- sort(coh$toxicity, decreasing = TRUE)
19	30x	coh$dose <- max(coh$dose)
20	30x	coh
21		})
22	10x	} else if (has_placebo) {
23		# Placebo will be plotted at y = 0 level.
24	8x	df$dose[df$dose == pbo_dose] <- 0
25		}
26	19x	df
27		}
28
29		# h_plot_data_df ----
30
31		## generic ----
32
33		#' Helper Function for the Plot Method of subclasses of [`GeneralData`]
34		#'
35		#' @description `r lifecycle::badge("experimental")`
36		#'
37		#' A method that transforms [`GeneralData`] objects into a `tibble` suitable for
38		#' plotting with `ggplot2` methods
39		#'
40		#' @param data (`GeneralData`)\cr object from which data is extracted and converted
41		#' into a data frame.
42		#' @param ... further arguments passed to class-specific methods.
43		#' @return `data.frame` containing columns for patient, cohort, dose and toxicity grade
44		#' @aliases h_plot_data_df
45		#'
46		setGeneric(
47		name = "h_plot_data_df",
48		def = function(data, ...) standardGeneric("h_plot_data_df"),
49		valueClass = "data.frame"
50		)
51
52		# Data ----
53
54		#' Helper Function for the Plot Method of [`Data`]
55		#'
56		#' @param data (`Data`)\cr object from which data is extracted and converted
57		#' into a data frame.
58		#' @param blind (`flag`)\cr should data be blinded?
59		#' If `TRUE`, then for each cohort, all DLTs are assigned to the first
60		#' subjects in the cohort. In addition, the placebo (if any) is set to the
61		#' active dose level for that cohort.
62		#' @param legend (`flag`)\cr Display the legend for the toxicity categories
63		#' @param ... further arguments passed to `data.frame` constructor.
64		#' It can be e.g. an extra `column_name = value` pair based on a slot
65		#' from `x` (which in this case might be a subclass of `Data`)
66		#' which does not appear in `Data`.
67		#' @return A `data.frame` object with columns patient, ID, cohort, dose and
68		#' toxicity.
69		#' @describeIn h_plot_data_df method for [`Data`].
70		setMethod(
71		f = "h_plot_data_df",
72		signature = signature(data = "Data"),
73		definition = function(data, blind = FALSE, legend = TRUE, ...) {
74	17x	df <- data.frame(
75	17x	patient = seq_along(data@x),
76	17x	ID = paste(" ", data@ID),
77	17x	cohort = data@cohort,
78	17x	dose = data@x,
79	17x	toxicity = ifelse(data@y == 1, "Yes", "No"),
80		...
81		)
82	17x	df <- h_blind_plot_data(df, blind, data@placebo, data@doseGrid[1])
83	17x	df
84		}
85		)
86
87		# DataOrdinal ----
88
89		#' Helper Function for the Plot Method of [`DataOrdinal`]
90		#'
91		#' @describeIn h_plot_data_df Class specific method for [`DataOrdinal`]
92		setMethod(
93		f = "h_plot_data_df",
94		signature = signature(data = "DataOrdinal"),
95		definition = function(data, blind = FALSE, legend = TRUE, ...) {
96	2x	df <- data.frame(
97	2x	patient = seq_along(data@x),
98	2x	ID = paste(" ", data@ID),
99	2x	cohort = data@cohort,
100	2x	dose = data@x,
101	2x	toxicity = names(data@yCategories)[1 + data@y],
102		...
103		)
104	2x	df <- h_blind_plot_data(df, blind, data@placebo, data@doseGrid[1])
105	2x	df
106		}
107		)
108
109
110		# h_plot_data_dataordinal
111
112		## Data ----
113
114		#' Helper Function for the Plot Method of the Data and DataOrdinal Classes
115		#'
116		#' @description `r lifecycle::badge("stable")`
117		#'
118		#' A method that creates a plot for [`Data`] and [`DataOrdinal`] objects.
119		#'
120		#' @note The default values of `tox_shapes` and `tox_labels` result in DLTs
121		#' being displayed as red triangles and other responses as black circles.
122		#' @return The [`ggplot2`] object.
123		#'
124		#' @rdname plot-Data
125		h_plot_data_dataordinal <- function(
126		x,
127		blind = FALSE,
128		legend = TRUE,
129		tox_labels = c(Yes = "red", No = "black"),
130		tox_shapes = c(Yes = 17L, No = 16L),
131		...) {
132	10x	assert_flag(blind)
133	10x	assert_flag(legend)
134	10x	assert_character(tox_labels, any.missing = FALSE, unique = TRUE)
135	10x	assert_integer(tox_shapes, any.missing = FALSE, unique = TRUE)
136	10x	assert_true(length(tox_shapes) == length(tox_labels))
137	10x	assert_subset(x@y, as.integer(0:(length(tox_shapes) - 1)))
138	10x	if (x@nObs == 0L) {
139	!	return()
140		}
141	10x	df <- h_plot_data_df(x, blind, ...)
142
143	10x	p <- ggplot(df, aes(x = patient, y = dose)) +
144	10x	geom_point(aes(shape = toxicity, colour = toxicity), size = 3) +
145	10x	scale_colour_manual(
146	10x	name = "Toxicity",
147	10x	values = tox_labels,
148	10x	breaks = names(tox_labels),
149	10x	guide = guide_legend(reverse = TRUE)
150		) +
151	10x	scale_shape_manual(
152	10x	name = "Toxicity",
153	10x	values = tox_shapes,
154	10x	breaks = names(tox_shapes),
155	10x	guide = guide_legend(reverse = TRUE)
156		) +
157	10x	scale_x_continuous(breaks = df$patient, minor_breaks = NULL) +
158	10x	scale_y_continuous(
159	10x	breaks = sort(unique(c(0, df$dose))),
160	10x	minor_breaks = NULL,
161	10x	limits = c(0, max(df$dose) * 1.1)
162		) +
163	10x	xlab("Patient") +
164	10x	ylab("Dose Level")
165
166	10x	p <- p + h_plot_data_cohort_lines(df$cohort, placebo = x@placebo)
167
168	10x	if (!blind) {
169	4x	p <- p +
170	4x	geom_text(
171	4x	aes(label = ID, size = 2),
172	4x	data = df,
173	4x	hjust = 0,
174	4x	vjust = 0.5,
175	4x	angle = 90,
176	4x	colour = "black",
177	4x	show.legend = FALSE
178		)
179		}
180
181	10x	if (!legend) {
182	6x	p <- p + theme(legend.position = "none")
183		}
184
185	10x	p
186		}
187
188		#' Helper Function Containing Common Functionality
189		#'
190		#' Used by `dose_grid_range-Data` and `dose_grid_range-DataOrdinal`
191		#' @param object (`Data` or `DataOrdinal`)\cr the object for which the dose grid
192		#' range is required
193		#' @param ignore_placebo (`flag`)\cr should placebo dose (if any) not be counted?
194		#'
195		h_obtain_dose_grid_range <- function(object, ignore_placebo) {
196	168x	assert_flag(ignore_placebo)
197
198	166x	dose_grid <- if (ignore_placebo && object@placebo && object@nGrid >= 1) {
199	12x	object@doseGrid[-1]
200		} else {
201	154x	object@doseGrid
202		}
203
204	166x	if (length(dose_grid) == 0L) {
205	10x	c(-Inf, Inf)
206		} else {
207	156x	range(dose_grid)
208		}
209		}
210
211		#' Convert a Ordinal Data to the Equivalent Binary Data for a Specific
212		#' Grade
213		#'
214		#' @description `r lifecycle::badge("experimental")`
215		#'
216		#' A simple helper function that takes a [`DataOrdinal`] object and an
217		#' integer grade and converts them to the equivalent `Data` object.
218		#'
219		#' @param data_ord (`DataOrdinal`)\cr the `DataOrdinal` object to covert
220		#' @param grade (`integer`)\cr the toxicity grade for which the equivalent data
221		#' is required.
222		#' @return A [`Data`] object.
223		#'
224		#' @export
225		h_convert_ordinal_data <- function(data_ord, grade) {
226		# Validate
227	27x	assert_integer(grade, len = 1, lower = 1)
228	27x	assert_class(data_ord, "DataOrdinal")
229		# Execute
230	27x	Data(
231	27x	ID = data_ord@ID,
232	27x	cohort = data_ord@cohort,
233	27x	x = data_ord@x,
234	27x	y = as.integer(data_ord@y >= grade),
235	27x	doseGrid = data_ord@doseGrid,
236	27x	nGrid = data_ord@nGrid,
237	27x	xLevel = data_ord@xLevel,
238	27x	placebo = data_ord@placebo
239		)
240		}

1		# nolint start
2
3		#####################################################################################
4		## Author: Daniel Sabanes Bove [sabanesd at* roche . com]
5		## Project: Object-oriented implementation of CRM designs
6		##
7		## Time-stamp: <[fromQuantiles.R] by DSB Fre 19/06/2015 14:22>
8		##
9		## Description:
10		## Find the best LogisticNormal model for a given set of quantiles at certain
11		## dose levels
12		##
13		## History:
14		## 11/02/2014 file creation
15		#####################################################################################
16
17		##' @include helpers.R
18		##' @include Model-class.R
19		{}
20
21
22		##' Convert prior quantiles (lower, median, upper) to logistic (log)
23		##' normal model
24		##'
25		##' This function uses generalized simulated annealing to optimize
26		##' a \code{\linkS4class{LogisticNormal}} model to be as close as possible
27		##' to the given prior quantiles.
28		##'
29		##' @param dosegrid the dose grid
30		##' @param refDose the reference dose
31		##' @param lower the lower quantiles
32		##' @param median the medians
33		##' @param upper the upper quantiles
34		##' @param level the credible level of the (lower, upper) intervals (default:
35		##' 0.95)
36		##' @param logNormal use the log-normal prior? (not default) otherwise, the
37		##' normal prior for the logistic regression coefficients is used
38		##' @param parstart starting values for the parameters. By default, these
39		##' are determined from the medians supplied.
40		##' @param parlower lower bounds on the parameters (intercept alpha and the
41		##' slope beta, the corresponding standard deviations and the correlation.)
42		##' @param parupper upper bounds on the parameters
43		##' @param seed seed for random number generation
44		##' @param verbose be verbose? (default)
45		##' @param control additional options for the optimisation routine, see
46		##' \code{\link[GenSA]{GenSA}} for more details
47		##' @return a list with the best approximating \code{model}
48		##' (\code{\linkS4class{LogisticNormal}} or
49		##' \code{\linkS4class{LogisticLogNormal}}), the resulting \code{quantiles}, the
50		##' \code{required} quantiles and the \code{distance} to the required quantiles,
51		##' as well as the final \code{parameters} (which could be used for running the
52		##' algorithm a second time)
53		##'
54		##' @importFrom GenSA GenSA
55		##' @importFrom mvtnorm rmvnorm
56		##' @export
57		##' @keywords programming
58		Quantiles2LogisticNormal <- function(dosegrid,
59		refDose,
60		lower,
61		median,
62		upper,
63		level = 0.95,
64		logNormal = FALSE,
65		parstart = NULL,
66		parlower = c(-10, -10, 0, 0, -0.95),
67		parupper = c(10, 10, 10, 10, 0.95),
68		seed = 12345,
69		verbose = TRUE,
70		control =
71		list(
72		threshold.stop = 0.01,
73		maxit = 50000,
74		temperature = 50000,
75		max.time = 600
76		)) {
77		## extracts and checks
78	2x	nDoses <- length(dosegrid)
79
80	2x	assert_flag(logNormal)
81	2x	assert_flag(verbose)
82	2x	assert_probability(level, bounds_closed = FALSE)
83	2x	stopifnot(
84	2x	!is.unsorted(dosegrid, strictly = TRUE),
85		## the medians must be monotonically increasing:
86	2x	!is.unsorted(median),
87	2x	identical(length(lower), nDoses),
88	2x	identical(length(median), nDoses),
89	2x	identical(length(upper), nDoses),
90	2x	all(lower < median),
91	2x	all(upper > median),
92	2x	identical(length(parlower), 5L),
93	2x	identical(length(parupper), 5L),
94	2x	all(parlower < parstart),
95	2x	all(parstart < parupper)
96		)
97
98		## put verbose argument in the control list
99	2x	control$verbose <- verbose
100
101		## parametrize in terms of the means for the intercept alpha and the
102		## (log) slope beta,
103		## the corresponding standard deviations and the correlation.
104		## Define start values for optimisation:
105	2x	startValues <-
106	2x	if (is.null(parstart)) {
107		## find approximate means for alpha and slope beta
108		## from fitting logistic model to medians:
109	1x	startAlphaBeta <-
110	1x	coef(lm(I(logit(median)) ~ I(log(dosegrid / refDose))))
111
112		## overall starting values:
113	1x	c(
114	1x	meanAlpha =
115	1x	startAlphaBeta[1],
116	1x	meanBeta =
117	1x	if (logNormal) log(startAlphaBeta[2]) else startAlphaBeta[2],
118	1x	sdAlpha =
119	1x	1,
120	1x	sdBeta =
121	1x	1,
122	1x	correlation =
123	1x	0
124		)
125		} else {
126	1x	parstart
127		}
128
129		## what is the target function which we want to minimize?
130	2x	target <- function(param) {
131		## form the mean vector and covariance matrix
132	4x	mean <- param[1:2]
133	4x	cov <- matrix(
134	4x	c(
135	4x	param[3]^2,
136	4x	prod(param[3:5]),
137	4x	prod(param[3:5]),
138	4x	param[4]^2
139		),
140	4x	nrow = 2L, ncol = 2L
141		)
142
143		## simulate from the corresponding normal distribution
144	4x	set.seed(seed)
145	4x	normalSamples <- mvtnorm::rmvnorm(
146	4x	n = 1e4L,
147	4x	mean = mean,
148	4x	sigma = cov
149		)
150
151		## extract separate coefficients
152	4x	alphaSamples <- normalSamples[, 1L]
153	4x	betaSamples <- if (logNormal) exp(normalSamples[, 2L]) else normalSamples[, 2L]
154
155		## and compute resulting quantiles
156	4x	quants <- matrix(
157	4x	nrow = length(dosegrid),
158	4x	ncol = 3L
159		)
160	4x	colnames(quants) <- c("lower", "median", "upper")
161
162		## process each dose after another:
163	4x	for (i in seq_along(dosegrid))
164		{
165		## create samples of the probability
166	20x	probSamples <-
167	20x	plogis(alphaSamples + betaSamples * log(dosegrid[i] / refDose))
168
169		## compute lower, median and upper quantile
170	20x	quants[i, ] <-
171	20x	quantile(probSamples,
172	20x	probs = c((1 - level) / 2, 0.5, (1 + level) / 2)
173		)
174		}
175
176		## now we can compute the target value
177	4x	ret <- max(abs(quants - c(lower, median, upper)))
178	4x	return(structure(ret,
179	4x	mean = mean,
180	4x	cov = cov,
181	4x	quantiles = quants
182		))
183		}
184
185	2x	set.seed(seed)
186		## now optimise the target
187	2x	genSAres <- GenSA::GenSA(
188	2x	par = startValues,
189	2x	fn = target,
190	2x	lower = parlower,
191	2x	upper = parupper,
192	2x	control = control
193		)
194	2x	distance <- genSAres$value
195	2x	pars <- genSAres$par
196	2x	targetRes <- target(pars)
197
198		## and construct the model
199	2x	ret <-
200	2x	if (logNormal) {
201	1x	LogisticLogNormal(
202	1x	mean = attr(targetRes, "mean"),
203	1x	cov = attr(targetRes, "cov"),
204	1x	ref_dose = refDose
205		)
206		} else {
207	1x	LogisticNormal(
208	1x	mean = attr(targetRes, "mean"),
209	1x	cov = attr(targetRes, "cov"),
210	1x	ref_dose = refDose
211		)
212		}
213
214		## return it together with the resulting distance and the quantiles
215	2x	return(list(
216	2x	model = ret,
217	2x	parameters = pars,
218	2x	quantiles = attr(targetRes, "quantiles"),
219	2x	required = cbind(lower, median, upper),
220	2x	distance = distance
221		))
222		}
223
224		##' Get the minimal informative unimodal beta distribution
225		##'
226		##' As defined in Neuenschwander et al (2008), this function computes the
227		##' parameters of the minimal informative unimodal beta distribution, given the
228		##' request that the p-quantile should be q, i.e. X ~ Be(a, b) with Pr(X <= q) =
229		##' p.
230		##'
231		##' @param p the probability (> 0 and < 1)
232		##' @param q the quantile (> 0 and < 1)
233		##' @return the two resulting beta parameters a and b in a list
234		##'
235		##' @export
236		##' @keywords programming
237		getMinInfBeta <- function(p, q) {
238	!	assert_probability(p, bounds_closed = FALSE)
239	!	assert_probability(q, bounds_closed = FALSE)
240
241	!	ret <-
242	!	if (q > p) {
243	!	list(
244	!	a = log(p) / log(q),
245	!	b = 1
246		)
247		} else {
248	!	list(
249	!	a = 1,
250	!	b = log(1 - p) / log(1 - q)
251		)
252		}
253
254	!	return(ret)
255		}
256
257
258		##' Construct a minimally informative prior
259		##'
260		##' This function constructs a minimally informative prior, which is captured in
261		##' a \code{\linkS4class{LogisticNormal}} (or
262		##' \code{\linkS4class{LogisticLogNormal}}) object.
263		##'
264		##' Based on the proposal by Neuenschwander et al (2008, Statistics in
265		##' Medicine), a minimally informative prior distribution is constructed. The
266		##' required key input is the minimum (\eqn{d_{1}} in the notation of the
267		##' Appendix A.1 of that paper) and the maximum value (\eqn{d_{J}}) of the dose
268		##' grid supplied to this function. Then \code{threshmin} is the probability
269		##' threshold \eqn{q_{1}}, such that any probability of DLT larger than
270		##' \eqn{q_{1}} has only 5% probability. Therefore \eqn{q_{1}} is the 95%
271		##' quantile of the beta distribution and hence \eqn{p_{1} = 0.95}. Likewise,
272		##' \code{threshmax} is the probability threshold \eqn{q_{J}}, such that any
273		##' probability of DLT smaller than \eqn{q_{J}} has only 5% probability
274		##' (\eqn{p_{J} = 0.05}). The probabilities \eqn{1 - p_{1}} and \eqn{p_{J}} can be
275		##' controlled with the arguments \code{probmin} and \code{probmax}, respectively.
276		##' Subsequently, for all doses supplied in the
277		##' \code{dosegrid} argument, beta distributions are set up from the assumption
278		##' that the prior medians are linear in log-dose on the logit scale, and
279		##' \code{\link{Quantiles2LogisticNormal}} is used to transform the resulting
280		##' quantiles into an approximating \code{\linkS4class{LogisticNormal}} (or
281		##' \code{\linkS4class{LogisticLogNormal}}) model. Note that the reference dose
282		##' is not required for these computations.
283		##'
284		##' @param dosegrid the dose grid
285		##' @param refDose the reference dose
286		##' @param threshmin Any toxicity probability above this threshold would
287		##' be very unlikely (see \code{probmin}) at the minimum dose (default: 0.2)
288		##' @param threshmax Any toxicity probability below this threshold would
289		##' be very unlikely (see \code{probmax}) at the maximum dose (default: 0.3)
290		##' @param probmin the prior probability of exceeding \code{threshmin} at the
291		##' minimum dose (default: 0.05)
292		##' @param probmax the prior probability of being below \code{threshmax} at the
293		##' maximum dose (default: 0.05)
294		##' @param \dots additional arguments for computations, see
295		##' \code{\link{Quantiles2LogisticNormal}}, e.g. \code{refDose} and
296		##' \code{logNormal=TRUE} to obtain a minimal informative log normal prior.
297		##' @return see \code{\link{Quantiles2LogisticNormal}}
298		##'
299		##' @example examples/MinimalInformative.R
300		##' @export
301		##' @keywords programming
302		MinimalInformative <- function(dosegrid,
303		refDose,
304		threshmin = 0.2,
305		threshmax = 0.3,
306		probmin = 0.05,
307		probmax = 0.05,
308		...) {
309		## extracts and checks
310	!	nDoses <- length(dosegrid)
311
312	!	assert_probability(threshmin, bounds_closed = FALSE)
313	!	assert_probability(threshmax, bounds_closed = FALSE)
314	!	assert_probability(probmin, bounds_closed = FALSE)
315	!	assert_probability(probmax, bounds_closed = FALSE)
316	!	stopifnot(
317	!	!is.unsorted(dosegrid, strictly = TRUE)
318		)
319	!	xmin <- dosegrid[1]
320	!	xmax <- dosegrid[nDoses]
321
322		## derive the beta distributions at the lowest and highest dose
323	!	betaAtMin <- getMinInfBeta(
324	!	q = threshmin,
325	!	p = 1 - probmin
326		)
327	!	betaAtMax <- getMinInfBeta(
328	!	q = threshmax,
329	!	p = probmax
330		)
331
332		## get the medians of those beta distributions
333	!	medianMin <- with(
334	!	betaAtMin,
335	!	qbeta(p = 0.5, a, b)
336		)
337	!	medianMax <- with(
338	!	betaAtMax,
339	!	qbeta(p = 0.5, a, b)
340		)
341
342		## now determine the medians of all beta distributions
343	!	beta <- (logit(medianMax) - logit(medianMin)) / (log(xmax) - log(xmin))
344	!	alpha <- logit(medianMax) - beta * log(xmax / refDose)
345	!	medianDosegrid <- plogis(alpha + beta * log(dosegrid / refDose))
346
347		## finally for all doses calculate 95% credible interval bounds
348		## (lower and upper)
349	!	lower <- upper <- dosegrid
350	!	for (i in seq_along(dosegrid))
351		{
352		## get min inf beta distribution
353	!	thisMinBeta <- getMinInfBeta(
354	!	p = 0.5,
355	!	q = medianDosegrid[i]
356		)
357
358		## derive required quantiles
359	!	lower[i] <- with(
360	!	thisMinBeta,
361	!	qbeta(p = 0.025, a, b)
362		)
363	!	upper[i] <- with(
364	!	thisMinBeta,
365	!	qbeta(p = 0.975, a, b)
366		)
367		}
368
369		## now go to Quantiles2LogisticNormal
370	!	Quantiles2LogisticNormal(
371	!	dosegrid = dosegrid,
372	!	refDose = refDose,
373	!	lower = lower,
374	!	median = medianDosegrid,
375	!	upper = upper,
376	!	level = 0.95,
377		...
378		)
379		}
380
381		# nolint end

1		# assertions ----
2
3		#' Additional Assertions for `checkmate`
4		#'
5		#' @description `r lifecycle::badge("experimental")`
6		#'
7		#' We provide additional assertion functions that can be used together with
8		#' the `checkmate` functions. These are described in individual help pages
9		#' linked below.
10		#'
11		#' @return Depending on the function prefix.
12		#' - `assert_` functions return the object invisibly if successful, and otherwise
13		#' throw an error message.
14		#' - `check_` functions return `TRUE` if successful, otherwise a string with the
15		#' error message.
16		#' - `test_` functions just return `TRUE` or `FALSE`.
17		#'
18		#' @seealso [assert_probabilities()], [assert_probability()],
19		#' [assert_probability_range()], [assert_length()].
20		#'
21		#' @name assertions
22		NULL
23
24		# check equality ----
25
26		#' Check if All Arguments Are Equal
27		#'
28		#' @description `r lifecycle::badge("experimental")`
29		#' Elements of `...` must be numeric vectors or scalars.
30		#'
31		#' This function performs an element-by-element comparison of the first object
32		#' provided in `...` with every other object in `...` and returns `TRUE` if all
33		#' comparisons are equal within a given tolerance and `FALSE` otherwise.
34		#'
35		#' @param ... (`numeric`)\cr vectors to be compared.
36		#' @param tol (`numeric`)\cr the maximum difference to be tolerated when
37		#' judging equality.
38		#'
39		#' @note If there are any missing or infinite values in `...`, this function
40		#' returns `FALSE`, regardless of the values of other elements in `...`.
41		#'
42		#' @note If elements in `...` are not all of the same length, `FALSE` is returned.
43		#'
44		#' @return `TRUE` if all element-by-element differences are less than `tolerance`
45		#' in magnitude, `FALSE` otherwise.
46		#' @seealso [`assertions`] for more details.
47		#'
48		#' @export
49		#' @examples
50		#' check_equal(1:2, 1:2) # TRUE
51		#' check_equal(1:2, 2:3) # "Not all equal"
52		#' check_equal(Inf, Inf) # "Not all equal"
53		#' check_equal(0.01, 0.02) # "Not all equal"
54		#' check_equal(0.01, 0.02, tol = 0.05) # TRUE
55		#' check_equal(1, c(1, 1)) # "Not all equal"
56		check_equal <- function(..., tol = sqrt(.Machine$double.eps)) {
57	14x	dot_args <- list(...)
58
59	14x	sapply(dot_args, assert_numeric)
60
61	14x	tmp <- sapply(dot_args, length)
62	14x	if (min(tmp) != max(tmp)) {
63	2x	return("Not all of same length")
64		}
65	12x	if (any(sapply(dot_args, is.na))) {
66	2x	return("Some entries NA")
67		}
68	10x	if (any(sapply(dot_args, is.infinite))) {
69	2x	return("Not all entries finite")
70		}
71	8x	if (!all(sapply(dot_args, test_numeric))) {
72	!	return("Not all numeric")
73		}
74
75	8x	all_ok <- test_true(
76	8x	all(
77	8x	sapply(
78	8x	2:length(dot_args),
79	8x	function(z) abs(dot_args[[1]] - dot_args[[z]]) < tol
80		)
81		)
82		)
83	8x	if (all_ok) {
84	4x	return(TRUE)
85		}
86	4x	"Not all equal"
87		}
88
89		#' Assert That All Arguments Are Equal
90		#'
91		#' @description `r lifecycle::badge("experimental")`
92		#' Elements of `...` must be numeric vectors or scalars.
93		#'
94		#' This function performs an element-by-element comparison of the first object
95		#' provided in `...` with every other object in `...` and throws an error if they
96		#' are not.
97		#'
98		#' @param ... (`numeric`)\cr vectors to be compared
99		#' @param tol (`numeric`)\cr the maximum difference to be tolerated when
100		#' judging equality
101		#'
102		#' @note If there are any missing or infinite values in `...`, this function
103		#' throws an error, regardless of the values of other elements in `...`.
104		#'
105		#' @note If elements in `...` are not all of the same length, an error is thrown.
106		#'
107		#' @return `list(...)`, invisibly.
108		#' @seealso [`assertions`] for more details.
109		#' @inheritParams checkmate::assert_numeric
110		#'
111		#' @export
112		#' @rdname check_equal
113		#' @examples
114		#' assert_equal(1:2, 1:2) # no error
115		#' assert_equal(0.01, 0.02, tol = 0.05) # no error
116		# nolint start
117		assert_equal <- function(..., tol = sqrt(.Machine$double.eps), .var.name = vname(x), add = NULL) {
118		# assert_equal <- makeAssertionFunction(check_equal) fails with error "Error
119		# in `checkmate::makeAssertion(..., res, .var.name, add)`: unused argument
120		# (add)", possibly because of the use of ... in check_equal.
121	7x	res <- check_equal(..., tol = tol)
122	7x	makeAssertion(list(...), res, .var.name, add)
123		}
124		# nolint end
125
126		# assert_probabilities ----
127
128		#' Check if an argument is a probability vector
129		#'
130		#' @description `r lifecycle::badge("stable")`
131		#'
132		#' Check if every element in a given numerical vector or matrix represents a
133		#' probability, that is a number within (0, 1) interval, that can optionally be
134		#' closed at any side.
135		#'
136		#' @note If there are any missing or non-finite values in `x`, this function
137		#' returns `FALSE`, regardless of the values of other elements in `x`.
138		#'
139		#' @param x (`numeric`)\cr vector or matrix with numerical values to check.
140		#' @param bounds_closed (`logical`)\cr should bounds be closed? This can be a
141		#' scalar or vector of length two. If it is a scalar, then its value applies
142		#' equally to lower bound \eqn{0} and upper bound \eqn{1}. If this is a vector
143		#' with two flags, the first flag corresponds to the lower bound \eqn{0}
144		#' only, and the second to the upper bound \eqn{1} only.
145		#' @inheritParams checkmate::check_numeric
146		#'
147		#' @return `TRUE` if successful, otherwise a string with the error message.
148		#'
149		#' @seealso [`assertions`] for more details.
150		#'
151		#' @export
152		#' @examples
153		#' x <- c(0, 0.2, 0.1, 0.3, 1)
154		#' check_probabilities(x)
155		#' check_probabilities(x, bounds_closed = FALSE)
156		#' check_probabilities(x, bounds_closed = c(FALSE, TRUE))
157		check_probabilities <- function(x, bounds_closed = TRUE, len = NULL, unique = FALSE, sorted = FALSE) {
158	14170x	assert_numeric(x)
159	14169x	assert_logical(bounds_closed, min.len = 1, max.len = 2, any.missing = FALSE)
160	14169x	assert_number(len, null.ok = TRUE)
161	14169x	assert_flag(sorted)
162
163	14169x	result <- check_numeric(
164	14169x	x,
165	14169x	finite = TRUE, any.missing = FALSE, len = len, unique = unique, sorted = sorted
166		)
167
168	14169x	if (isTRUE(result)) {
169	14091x	in_bounds <- all(h_in_range(x, range = c(0L, 1L), bounds_closed = bounds_closed))
170	14091x	if (!in_bounds) {
171	140x	result <- paste(
172	140x	"Probability must be within",
173	140x	ifelse(bounds_closed[1], "[0,", "(0,"),
174	140x	ifelse(tail(bounds_closed, 1), "1]", "1)"),
175	140x	"bounds but it is not"
176		)
177		}
178		}
179
180	14169x	result
181		}
182
183		#' @rdname check_probabilities
184		#' @inheritParams check_probabilities
185		#' @export
186		assert_probabilities <- makeAssertionFunction(check_probabilities)
187
188		#' @rdname check_probabilities
189		#' @inheritParams check_probabilities
190		#' @export
191		test_probabilities <- makeTestFunction(check_probabilities)
192
193		#' @rdname check_probabilities
194		#' @inheritParams check_probabilities
195		#' @export
196		expect_probabilities <- makeExpectationFunction(check_probabilities)
197
198		# assert_probability ----
199
200		#' Check if an argument is a single probability value
201		#'
202		#' @description `r lifecycle::badge("stable")`
203		#'
204		#' Check if a given value represents a probability, that is a number within
205		#' (0, 1) interval, that can optionally be closed at any side.
206		#'
207		#' @param x (`number`)\cr a single value to check.
208		#' @inheritParams check_probabilities
209		#'
210		#' @return `TRUE` if successful, otherwise a string with the error message.
211		#'
212		#' @seealso [`assertions`] for more details.
213		#'
214		#' @export
215		#' @examples
216		#' check_probability(0.5)
217		#' check_probability(0, bounds_closed = FALSE)
218		#' check_probability(0, bounds_closed = c(FALSE, TRUE))
219		check_probability <- function(x, bounds_closed = TRUE) {
220	7429x	check_probabilities(x = x, bounds_closed = bounds_closed, len = 1)
221		}
222
223		#' @rdname check_probability
224		#' @inheritParams check_probability
225		#' @export
226		assert_probability <- makeAssertionFunction(check_probability)
227
228		#' @rdname check_probability
229		#' @inheritParams check_probability
230		#' @export
231		test_probability <- makeTestFunction(check_probability)
232
233		#' @rdname check_probability
234		#' @inheritParams check_probability
235		#' @export
236		expect_probability <- makeExpectationFunction(check_probability)
237
238		# assert_probability_range ----
239
240		#' Check if an argument is a probability range
241		#'
242		#' @description `r lifecycle::badge("stable")`
243		#'
244		#' Check if a given numerical interval represents a probability range, that is
245		#' a sub-interval of (0, 1) interval, that can optionally be closed at any side.
246		#'
247		#' @param x (`number`)\cr an interval to check.
248		#' @inheritParams check_probabilities
249		#'
250		#' @return `TRUE` if successful, otherwise a string with the error message.
251		#'
252		#' @seealso [`assertions`] for more details.
253		#'
254		#' @export
255		#' @examples
256		#' x <- c(0, 0.2)
257		#' check_probability_range(x)
258		#' check_probability_range(rev(x))
259		#' check_probability_range(x, bounds_closed = FALSE)
260		#' check_probability_range(x, bounds_closed = c(FALSE, TRUE))
261		check_probability_range <- function(x, bounds_closed = TRUE) {
262	723x	check_probabilities(x = x, bounds_closed = bounds_closed, len = 2, sorted = TRUE)
263		}
264
265		#' @rdname check_probability_range
266		#' @inheritParams check_probability_range
267		#' @export
268		assert_probability_range <- makeAssertionFunction(check_probability_range)
269
270		#' @rdname check_probability_range
271		#' @inheritParams check_probability_range
272		#' @export
273		test_probability_range <- makeTestFunction(check_probability_range)
274
275		#' @rdname check_probability_range
276		#' @inheritParams check_probability_range
277		#' @export
278		expect_probability_range <- makeExpectationFunction(check_probability_range)
279
280		# assert_length ----
281
282		#' Check if vectors are of compatible lengths
283		#'
284		#' @description `r lifecycle::badge("stable")`
285		#'
286		#' Two vectors are of compatible size if and only if: \cr
287		#' 1. At least one vector has size 1 \cr
288		#' 2. or both vectors are of the same size. \cr
289		#'
290		#' @param x (`any`)\cr the first vector, any object for which [length()]
291		#' function is defined.
292		#' @param len (`count`)\cr the length of the second vector.
293		#' @inheritParams checkmate::check_numeric
294		#'
295		#' @return `TRUE` if successful, otherwise a string with the error message.
296		#'
297		#' @seealso [`assertions`] for more details.
298		#'
299		#' @export
300		#' @examples
301		#' check_length(1:5, 1)
302		#' check_length(1:5, 6)
303		#' check_length(1:5, 5)
304		#' check_length(10, 1)
305		#' check_length(10, 9)
306		check_length <- function(x, len) {
307	41138x	x_len <- length(x)
308	41138x	assert_true(x_len >= 1L)
309	41137x	assert_count(len)
310
311	41133x	if (x_len == 1L \|\| len == 1L \|\| x_len == len) {
312	41104x	TRUE
313		} else {
314	29x	paste(
315	29x	"x is of length",
316	29x	x_len,
317	29x	"which is not allowed; the allowed lengths are: 1 or",
318	29x	len,
319	29x	collapse = ""
320		)
321		}
322		}
323
324		#' @rdname check_length
325		#' @inheritParams check_length
326		#' @export
327		assert_length <- makeAssertionFunction(check_length)
328
329		#' @rdname check_length
330		#' @inheritParams check_length
331		#' @export
332		test_length <- makeTestFunction(check_length)
333
334		# assert_range ----
335
336		#' Check that an argument is a numerical range
337		#'
338		#' @description `r lifecycle::badge("stable")`
339		#'
340		#' An argument `x` is a numerical range if and only if (all conditions must be met):
341		#' 1. Is an object of type: `integer` or `double`.
342		#' 2. Is a vector or length two such that the value of the first number is not
343		#' less than the second number. Equalness is allowed if and only if `unique` flag
344		#' is set to `TRUE`.
345		#' 3. Lower bound of the interval is greater than or equal to `lower` and
346		#' upper bound of the interval is less than or equal to `upper`.
347		#' 4. It contains only finite (given that `finite` is `TRUE`) and non-missing values.
348		#'
349		#' @inheritParams checkmate::check_numeric
350		#'
351		#' @return `TRUE` if successful, otherwise a string with the error message.
352		#'
353		#' @seealso [`assertions`] for more details.
354		#'
355		#' @export
356		#' @examples
357		#' check_range(c(1, 5))
358		#' check_range(c(-5, 1))
359		#' check_range(c(4, 1))
360		#' check_range(c(1, 1))
361		#' check_range(c(1, 1), unique = FALSE)
362		#' check_range(1:3)
363		check_range <- function(x, lower = -Inf, upper = Inf, finite = FALSE, unique = TRUE) {
364	91x	assert_number(lower)
365	90x	assert_number(upper)
366	89x	assert_flag(finite)
367	88x	assert_flag(unique)
368
369	87x	result <- check_numeric(
370	87x	x,
371	87x	lower = lower,
372	87x	upper = upper,
373	87x	finite = finite,
374	87x	any.missing = FALSE,
375	87x	len = 2,
376	87x	unique = unique,
377	87x	sorted = TRUE
378		)
379
380	87x	if (!isTRUE(result)) {
381	24x	result <- paste("x must be a valid numerical range.", result)
382		}
383	87x	result
384		}
385
386		#' @rdname check_range
387		#' @inheritParams check_range
388		#' @export
389		assert_range <- makeAssertionFunction(check_range)
390
391		#' @rdname check_range
392		#' @inheritParams check_range
393		#' @export
394		test_range <- makeTestFunction(check_range)
395
396		#' @rdname check_range
397		#' @inheritParams check_range
398		#' @export
399		expect_range <- makeExpectationFunction(check_range)

1		# tidy ----
2
3		## generic ----
4
5		#' Tidying `CrmPackClass` objects
6		#'
7		#' @description `r lifecycle::badge("experimental")`
8		#'
9		#' In the spirit of the `broom` package, provide a method to convert a
10		#' `CrmPackClass` object to a (list of) tibbles.
11		#'
12		#' @param x (`CrmPackClass`)\cr the object to be tidied.
13		#' @param ... potentially used by class-specific methods
14		#'
15		#' @return A (list of) tibble(s) representing the object in tidy form.
16		#'
17		#' @export
18		#'
19		setGeneric(
20		name = "tidy",
21		def = function(x, ...) {
22	592x	standardGeneric("tidy")
23		}
24		)
25
26		## CrmPackClass ----
27
28		#' Tidy a `CrmPackClass` Object
29		#'
30		#' Following the principles of the `broom` package, convert a `CrmPackClass`
31		#' object to a (list of) tibbles. This is a basic, default representation.
32		#'
33		#' @param x (`CrmPackClass`)\cr the object to be tidied.
34		#' @param ... potentially used by class-specific methods.
35		#' @rdname tidy
36		#' @aliases tidy-CrmPackClass
37		#' @keywords methods
38		#' @example examples/CrmPackClass-method-tidy.R
39		#'
40		#' @export
41		setMethod(
42		f = "tidy",
43		signature = signature(x = "CrmPackClass"),
44		definition = function(x, ...) {
45	461x	rv <- h_tidy_all_slots(x) %>% h_tidy_class(x)
46	461x	if (length(rv) == 1) {
47	73x	rv[[names(rv)[1]]] %>% h_tidy_class(x)
48		} else {
49	388x	rv
50		}
51		}
52		)

1		#' @include McmcOptions-class.R
2		#' @include Samples-validity.R
3		#' @include CrmPackClass-class.R
4		NULL
5
6		# Samples ----
7
8		## class ----
9
10		#' `Samples`
11		#'
12		#' @description `r lifecycle::badge("stable")`
13		#'
14		#' [`Samples`] is the class to store the MCMC samples.
15		#'
16		#' @slot data (`list`)\cr MCMC samples of the parameter. Each entry in this list
17		#' must be a vector (in case of a scalar parameter) or matrix (in case of a
18		#' vector-valued parameter) with samples.
19		#' In case of matrix, every row is a separate sample, while columns correspond
20		#' to the dimension of the parameter.
21		#' @slot options (`McmcOptions`)\cr MCMC options that were used to generate the
22		#' samples.
23		#'
24		#' @aliases Samples
25		#' @export
26		#'
27		.Samples <- setClass(
28		Class = "Samples",
29		slots = c(
30		data = "list",
31		options = "McmcOptions"
32		),
33		prototype = prototype(
34		data = list(),
35		options = McmcOptions()
36		),
37		contains = "CrmPackClass",
38		validity = v_samples
39		)
40
41		## constructor ----
42
43		#' @rdname Samples-class
44		#'
45		#' @param data see slot definition.
46		#' @param options see slot definition.
47		#'
48		#' @export
49		#' @example examples/Samples-class.R
50		#'
51		Samples <- function(data, options) {
52	3186x	new("Samples", data = data, options = options)
53		}
54
55		## default constructor ----
56
57		#' @rdname Samples-class
58		#' @note Typically, end users will not use the `.DefaultSamples()` function.
59		#' @export
60		.DefaultSamples <- function() {
61	4x	mcmc(
62	4x	data = .DefaultData(),
63	4x	model = .DefaultLogisticLogNormal(),
64	4x	options = .DefaultMcmcOptions()
65		)
66		}

1		#' @include helpers.R
2		#' @include McmcOptions-validity.R
3		#' @include CrmPackClass-class.R
4		NULL
5
6		# McmcOptions ----
7
8		## class ----
9
10		#' `McmcOptions`
11		#'
12		#' @description `r lifecycle::badge("stable")`
13		#'
14		#' [`McmcOptions`] is a class for the three canonical MCMC options as well as
15		#' Random Number Generator settings.
16		#'
17		#' @slot iterations (`count`)\cr number of MCMC iterations.
18		#' @slot burnin (`count`)\cr number of burn-in iterations which are not saved.
19		#' @slot step (`count`)\cr only every `step`-th iteration is saved after
20		#' the `burnin`. In other words, a sample from iteration
21		#' `i = 1,...,iterations`, is saved if and only if
22		#' `(i - burnin) mod step = 0`.\cr
23		#' For example, for `iterations = 6`, `burnin = 0` and `step = 2`, only
24		#' samples from iterations `2,4,6` will be saved.
25		#' @slot rng_kind (`string`)\cr a Random Number Generator (RNG) type used by
26		#' [`rjags`]. It must be one out of the following four values:
27		#' `base::Wichmann-Hill`, `base::Marsaglia-Multicarry`,
28		#' `base::Super-Duper`, `base::Mersenne-Twister`, or `NA_character_`.
29		#' If it is `NA_character_` (default), then the RNG kind will be chosen by
30		#' [`rjags`].
31		#' @slot rng_seed (`number`)\cr a Random Number Generator (RNG) seed
32		#' used by [`rjags`] for a chosen `rng_kind`. It must be an integer scalar or
33		#' `NA_integer_`, which means that the seed will be chosen by [`rjags`].
34		#'
35		#' @aliases McmcOptions
36		#' @export
37		#'
38		.McmcOptions <- setClass(
39		Class = "McmcOptions",
40		slots = c(
41		iterations = "integer",
42		burnin = "integer",
43		step = "integer",
44		rng_kind = "character",
45		rng_seed = "integer"
46		),
47		prototype = prototype(
48		iterations = 1000L,
49		burnin = 100L,
50		step = 2L,
51		rng_kind = NA_character_,
52		rng_seed = NA_integer_
53		),
54		contains = "CrmPackClass",
55		validity = v_mcmc_options
56		)
57
58		## constructor ----
59
60		#' @rdname McmcOptions-class
61		#'
62		#' @param burnin (`count`)\cr number of burn-in iterations which are not saved.
63		#' @param step (`count`)\cr only every step-th iteration is saved after
64		#' the burn-in.
65		#' @param samples (`count`)\cr number of resulting samples.
66		#' @param rng_kind (`string`)\cr the name of the RNG type. Possible types are:
67		#' `Wichmann-Hill`, `Marsaglia-Multicarry`, `Super-Duper`, `Mersenne-Twister`.
68		#' If it is `NA` (default), then the RNG kind will be chosen by `[rjags`].
69		#' @param rng_seed (`number`)\cr RNG seed corresponding to chosen `rng_kind`.
70		#' It must be an integer value or `NA` (default), which means that the seed
71		#' will be chosen by `[rjags`].
72		#'
73		#' @export
74		#' @example examples/McmcOptions-class-McmcOptions.R
75		#'
76		McmcOptions <- function(burnin = 1e4L,
77		step = 2L,
78		samples = 1e4L,
79		rng_kind = NA_character_,
80		rng_seed = NA_integer_) {
81	2839x	assert_count(burnin, positive = TRUE)
82	2839x	assert_count(step, positive = TRUE)
83	2839x	assert_count(samples, positive = TRUE)
84	2839x	assert_string(rng_kind, na.ok = TRUE)
85	2839x	assert_count(rng_seed, na.ok = TRUE)
86
87	2839x	if (!is.na(rng_kind)) {
88	345x	rng_kind <- paste0("base::", rng_kind)
89		} else {
90	2494x	rng_kind <- NA_character_
91		}
92	2839x	if (!is.na(rng_seed)) {
93	344x	rng_seed <- as.integer(rng_seed)
94		} else {
95	2495x	rng_seed <- NA_integer_
96		}
97
98	2839x	.McmcOptions(
99	2839x	iterations = as.integer(burnin + (step * samples)),
100	2839x	burnin = as.integer(burnin),
101	2839x	step = as.integer(step),
102	2839x	rng_kind = rng_kind,
103	2839x	rng_seed = as.integer(rng_seed)
104		)
105		}
106
107		## default constructor ----
108
109		#' @rdname McmcOptions-class
110		#' @note Typically, end users will not use the `.DefaultMcmcOptions()` function.
111		#' @export
112		.DefaultMcmcOptions <- function() {
113	20x	McmcOptions(
114	20x	burnin = 250,
115	20x	samples = 1000
116		)
117		}

1		#' @include helpers.R
2		#' @include ModelParams-validity.R
3		#' @include CrmPackClass-class.R
4		NULL
5
6		# ModelParamsNormal ----
7
8		## class ----
9
10		#' `ModelParamsNormal`
11		#'
12		#' @description `r lifecycle::badge("experimental")`
13		#'
14		#' [`ModelParamsNormal`] is the class for a bivariate normal model parameters,
15		#' i.e. the mean vector, covariance matrix and precision matrix.
16		#' The precision matrix is an inverse of the covariance matrix in the
17		#' `JAGS` and it is computed internally by the object constructor function.
18		#'
19		#' @slot mean (`numeric`)\cr the mean vector.
20		#' @slot cov (`matrix`)\cr the covariance matrix.
21		#' @slot prec (`matrix`)\cr the precision matrix, which is an inverse matrix of the `cov`.
22		#'
23		#' @seealso [`ModelLogNormal`], [`LogisticNormalMixture`].
24		#'
25		#' @aliases ModelParamsNormal
26		#' @export
27		#'
28		.ModelParamsNormal <- setClass(
29		Class = "ModelParamsNormal",
30		slots = c(
31		mean = "numeric",
32		cov = "matrix",
33		prec = "matrix"
34		),
35		contains = "CrmPackClass",
36		validity = v_model_params_normal
37		)
38
39		## constructor ----
40
41		#' @rdname ModelParamsNormal-class
42		#'
43		#' @param mean (`numeric`)\cr the prior mean vector.
44		#' @param cov (`matrix`)\cr the prior covariance matrix. The precision matrix
45		#' `prec` is internally calculated as an inverse of `cov`.
46		#'
47		#' @export
48		#' @examples
49		#' ModelParamsNormal(mean = c(1, 6), cov = diag(2))
50		ModelParamsNormal <- function(mean, cov) {
51	680x	assert_matrix(
52	680x	cov,
53	680x	mode = "numeric",
54	680x	any.missing = FALSE,
55	680x	nrows = length(mean),
56	680x	ncols = length(mean)
57		)
58		# To ensure that `cov` is invertible:
59	680x	assert_true(h_is_positive_definite(cov, length(mean)))
60
61	680x	.ModelParamsNormal(
62	680x	mean = mean,
63	680x	cov = cov,
64	680x	prec = solve(cov)
65		)
66		}
67
68		## default constructor ----
69
70		#' @rdname ModelParamsNormal-class
71		#' @note Typically, end users will not use the `.ModelPAramsNormal()` function.
72		#' @export
73		.DefaultModelParamsNormal <- function() {
74	5x	ModelParamsNormal(
75	5x	mean = c(1, 0),
76	5x	cov = matrix(c(1, 0, 0, 1), nrow = 2)
77		)
78		}

1		#' @include McmcOptions-methods.R
2		NULL
3
4		# v_samples ----
5
6		#' Internal Helper Functions for Validation of [`Samples`] Objects
7		#'
8		#' @description These functions are only used internally to validate the format
9		#' of an input [`Samples`] or inherited classes and therefore not exported.
10		#'
11		#' @name v_samples_objects
12		#' @param object (`Samples`)\cr object to validate.
13		#' @return A `character` vector with the validation failure messages, or `TRUE`
14		#' in case validation passes.
15		NULL
16
17		#' @describeIn v_samples_objects validates that the [`Samples`] object contains
18		#' valid `data` slot.
19		v_samples <- function(object) {
20	7x	v <- Validate()
21	7x	v$check(
22	7x	all(sapply(object@data, NROW) == size(object@options)),
23	7x	"Every element in data must be of the same length (no. of rows) as the sample size was"
24		)
25	7x	v$check(
26	7x	all(sapply(object@data, test_numeric, finite = TRUE, any.missing = FALSE)),
27	7x	"Every element in data must be a finite object of type integer or double"
28		)
29	7x	v$result()
30		}

1		#' Apply a Function to Subsets of Data Frame.
2		#'
3		#' @description `r lifecycle::badge("experimental")`
4		#'
5		#' `dapply` splits the data `df` into the subsets defined by `f`,
6		#' and applies function `FUN` to each of the subset.
7		#' All the results are row-binded and returned as `data.frame` object.
8		#'
9		#' @param df (`data frame`)\cr data set to be divided into groups.
10		#' @param f (`factor` or `formula` or `list`)\cr a factor in the sense that
11		#' `as.factor(f)` defines the grouping, or a `list` of such factors in which
12		#' case their interaction is used for the grouping. `f` can also be a formula
13		#' of the form `~ g1 + ... + gk` to split by the interaction of the variables
14		#' `g1, ..., gk`. This parameter is passed directly into [split()] function.
15		#' @param FUN (`function`)\cr the function to be applied to each subset of `df`
16		#' defined by `f`.
17		#' @param ... parameters passed to [lapply()], which is used when applying a
18		#' function `FUN` over groups defined by `f`.
19		#'
20		#' @return The [`data.frame`] object with results from `FUN`.
21		#'
22		#' @export
23		#' @example examples/utils-dapply.R
24		#'
25		dapply <- function(df, f, FUN, ...) {
26	11x	assert_data_frame(df)
27
28	11x	list_df <- split(df, f = f)
29	11x	list_df <- lapply(list_df, FUN, ...)
30	11x	df2 <- do.call(rbind, list_df)
31	11x	rownames(df2) <- NULL
32	11x	df2
33		}

1		#' Convenience function to make barplots of percentages
2		#'
3		#' @param x vector of samples
4		#' @param description xlab string
5		#' @param xaxisround rounding for xaxis labels (default: 0, i.e. integers will
6		#' be used)
7		#'
8		#' @return the ggplot2 object
9		#'
10		#' @keywords internal
11		#' @importFrom ggplot2 ggplot geom_histogram aes xlab ylab xlim
12		h_barplot_percentages <- function(x, description, xaxisround = 0) {
13	6x	assert_number(xaxisround, lower = 0)
14	4x	assert_character(description, len = 1, any.missing = FALSE)
15	2x	assert_numeric(x)
16
17	1x	tabx <- table(x) / length(x)
18	1x	dat <- data.frame(x = as.numeric(names(tabx)), perc = as.numeric(tabx) * 100)
19	1x	ggplot() +
20	1x	geom_bar(aes(x = x, y = perc),
21	1x	data = dat,
22	1x	stat = "identity",
23	1x	position = "identity",
24	1x	width = ifelse(nrow(dat) > 1, min(diff(dat$x)) / 2, 1)
25		) +
26	1x	xlab(description) +
27	1x	ylab("Percent") +
28	1x	scale_x_continuous(
29	1x	breaks =
30	1x	round(dat$x, xaxisround)
31		)
32		}
33
34
35
36		#' Helper function to calculate percentage of true stopping rules for
37		#' report label output
38		#' calculates true column means and converts output into percentages
39		#' before combining the output with the report label; output is passed
40		#' to [`show()`] and output with cat to console
41		#'
42		#' @param stop_report object from summary method
43		#' @return named list with label and percentage of rule activation
44
45
46		h_calc_report_label_percentage <- function(stop_report) {
47	2x	stop_pct <- colMeans(stop_report) * 100
48	2x	stop_pct_to_print <- stop_pct[!is.na(names(stop_pct))]
49	2x	return(stop_pct_to_print)
50		}
51
52
53
54		#' Helper function to calculate average across iterations for each additional
55		#' reporting parameter
56		#' extracts parameter names as specified by user and averaged the values
57		#' for each specified parameter to [`show()`] and output with cat to console
58		#'
59		#' @param stats_list object from simulation with nested parameter values
60		#' (sublist for each parameter)
61		#' @return list of parameter names and averaged values for console output
62
63
64		h_summarize_add_stats <- function(stats_list) {
65		# Extract the parameter names
66	2x	param_names <- names(stats_list[[1]])
67
68		# Calculate the average for each parameter
69	2x	averages <- lapply(param_names, function(param) {
70	4x	values <- sapply(stats_list, function(x) x[[param]])
71	4x	mean(values)
72		})
73
74	2x	return(list(param_names, averages))
75		}

1		#' Convert a Samples Object from an ordinal Model to the Equivalent Samples Object
2		#' from a Binary Model
3		#'
4		#' @description `r lifecycle::badge("experimental")`
5		#'
6		#' A simple helper function that converts a [`Samples`] object from the fit of an
7		#' ordinal CRM model to that which would have been obtained from fitting a binary
8		#' CRM model for toxicities of a specified grade to the same observed data.
9		#'
10		#' @param obj (`Samples`)\cr the `Samples` object to covert
11		#' @param grade (`integer`)\cr the toxicity grade for which the equivalent data
12		#' is required.
13		#' @return A [`Samples`] object.
14		#'
15		#' @export
16		h_convert_ordinal_samples <- function(obj, grade) {
17		# Validate
18	27x	assert_integer(grade, len = 1, lower = 1)
19	25x	assert_class(obj, "Samples")
20	24x	assert_subset(c(paste0("alpha", 1:grade), "beta"), names(obj@data))
21		# Execute
22	23x	d <- list("alpha0" = obj@data[[paste0("alpha", grade)]], "alpha1" = obj@data$beta)
23	23x	Samples(data = d, options = obj@options)
24		}

1		#' @include McmcOptions-class.R
2		NULL
3
4		# size ----
5
6		## generic ----
7
8		#' Size of an Object
9		#'
10		#' @description `r lifecycle::badge("stable")`
11		#'
12		#' A method that computes the size of a given object. This can be for instance
13		#' a size of a MCMC sample, or the size of a cohort. See the help of a specific
14		#' method for more details.
15		#'
16		#' @param object (`McmcOptions` or `Samples` or `CohortSize`)\cr an object
17		#' for which the size is computed.
18		#' @param ... further arguments passed to `size` specific methods.
19		#'
20		#' @return A size of a given object.
21		#' @export
22		#'
23		setGeneric(
24		name = "size",
25		def = function(object, ...) {
26	80164x	standardGeneric("size")
27		},
28		valueClass = "integer"
29		)
30
31		## McmcOptions ----
32
33		#' @describeIn size compute the number of MCMC samples based on `McmcOptions`
34		#' object.
35		#' @aliases size-McmcOptions
36		#' @example examples/McmcOptions-methods-size.R
37		setMethod(
38		f = "size",
39		signature = signature(object = "McmcOptions"),
40		definition = function(object, ...) {
41	41306x	iterations_relative <- object@iterations - object@burnin
42	41306x	if (iterations_relative <= 0) {
43	!	return(0L)
44		}
45	41306x	as.integer(floor(iterations_relative / object@step))
46		}
47		)
48
49		# saveSample ----
50
51		## generic ----
52
53		#' Determining if this Sample Should be Saved
54		#'
55		#' @description `r lifecycle::badge("stable")`
56		#'
57		#' A method that determines if a sample from a given `iteration` should be
58		#' saved. The sample should be saved if and only if:
59		#' it is not in burn-in period and it matches the `step`.
60		#'
61		#' @param object (`McmcOptions`)\cr object based on which the answer is
62		#' determined.
63		#' @param iteration (`count`)\cr the current iteration index.
64		#' @param ... not used.
65		#' @return `TRUE` if this sample should be saved.
66		#' @export
67		#'
68		setGeneric(
69		name = "saveSample",
70		def = function(object, iteration, ...) {
71	21734x	standardGeneric("saveSample")
72		},
73		valueClass = "logical"
74		)
75
76		## McmcOptions ----
77
78		#' @describeIn saveSample determine if a sample should be saved.
79		#' @aliases saveSample-McmcOptions
80		#' @example examples/McmcOptions-methods-saveSample.R
81		setMethod(
82		f = "saveSample",
83		signature = signature(object = "McmcOptions"),
84		definition = function(object, iteration, ...) {
85	21734x	iteration_relative <- iteration - object@burnin
86	21734x	iteration_relative > 0 && ((iteration_relative %% object@step) == 0)
87		}
88		)

1		# v_mcmc_options ----
2
3		#' Internal Helper Functions for Validation of [`McmcOptions`] Objects
4		#'
5		#' @description `r lifecycle::badge("stable")`
6		#'
7		#' These functions are only used internally to validate the format of an input
8		#' [`McmcOptions`] or inherited classes and therefore not exported.
9		#'
10		#' @name v_mcmcoptions_objects
11		#' @param object (`McmcOptions`)\cr object to validate.
12		#' @return A `character` vector with the validation failure messages,
13		#' or `TRUE` in case validation passes.
14		NULL
15
16		#' @describeIn v_mcmcoptions_objects validates that the [`McmcOptions`]
17		#' object contains valid integer scalars `iterations`, `burnin` and `step`
18		#' as well as proper parameters for Random Number Generator.
19		v_mcmc_options <- function(object) {
20	4x	v <- Validate()
21	4x	allowed_rng_kinds <- c(
22	4x	"base::Wichmann-Hill",
23	4x	"base::Marsaglia-Multicarry",
24	4x	"base::Super-Duper",
25	4x	"base::Mersenne-Twister",
26	4x	NA_character_
27		)
28
29	4x	v$check(
30	4x	test_int(object@iterations, lower = 1L),
31	4x	"iterations must be integer scalar greater than or equal to 1"
32		)
33	4x	v$check(
34	4x	test_int(object@burnin, lower = 0L),
35	4x	"burn-in must be non-negative integer scalar"
36		)
37		# This below check should not be conducted in above test, using
38		# `upper = object@iterations -1` argument, since object@iterations might be
39		# not-valid. In such a case `test_int` throws an internal error.
40	4x	v$check(
41	4x	test_true(object@burnin < object@iterations),
42	4x	"burn-in must be lower than iterations"
43		)
44	4x	v$check(
45	4x	test_int(object@step, lower = 1L),
46	4x	"step must be integer scalar greater than or equal to 1"
47		)
48
49	4x	is_rng_kind_scalar <- test_string(object@rng_kind, na.ok = TRUE)
50	4x	v$check(is_rng_kind_scalar, "rng_kind must be a single string")
51	4x	v$check(
52	4x	test_subset(object@rng_kind, allowed_rng_kinds),
53	4x	paste0(
54	4x	"rng_kind must one of the following: ",
55	4x	paste(allowed_rng_kinds, collapse = ", "),
56	4x	". User specifies the rng_kind without `base::` prefix"
57		)
58		)
59
60	4x	is_rng_seed_scalar <- test_int(object@rng_seed, na.ok = TRUE)
61	4x	v$check(is_rng_seed_scalar, "rng_seed must be an integer scalar")
62
63		# Below `if` condition is not only reasonable but also needed as R CMD check
64		# is activating some stricter checks and it fails when arguments to `\|\|` are
65		# not scalars, even if `\|\|` works well with vectors of length > 1.
66	4x	if (is_rng_kind_scalar && is_rng_seed_scalar) {
67	3x	v$check(
68	3x	!is.na(object@rng_kind) \|\| is.na(object@rng_seed),
69	3x	"rng_seed supplied but rng_kind not set"
70		)
71		}
72	4x	v$result()
73		}